(module rpc-marshal mzscheme
        (require (lib "time.ss" "srfi" "19"))
        (provide rpc-marshal
                 rpc-de-marshal
                 rpc-register-marshaller
                 rpc-register-atom-marshaller
                 string->any
                 any->string
                 )
        
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        ;;;; Support functions/syntax
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        
        (define-syntax r-name
          (syntax-rules ()
            ((_ x) (cadr x))))
        
        (define-syntax r-type-identifier
          (syntax-rules ()
            ((_ x) (car x))))
        
        (define-syntax r-marshaller
          (syntax-rules ()
            ((_ x) (caddr x))))

        ;;;; * procedure-with-name?
        (define (procedure-with-name? x)
          (and (procedure? x)
               (not (eq? (object-name x) #f))))
        
        ;;;; * hash-table-equal?
        (define (hash-table-equal? x)
          (hash-table? x 'equal))
        
        ;;;; * identity
        (define (identity x) x)
        
        ;;;; * internal-rpc-register-marshaller
        (define (internal-rpc-register-marshaller name type-identifier marshaller de-marshaller . before)

          ;;; check existence
          (letrec ((exist? (lambda (L)
                             (if (null? L)
                                 #f
                                 (let ((e (car L)))
                                   (if (eq? (r-name e) name)
                                       #t
                                       (exist? (cdr L))))))))
            (if (exist? marshallers)
                (error (format "A marshaller of name ~s already exists." name))))
          
          ;;; register
          (if (null? before)
                (begin
                  (hash-table-put! de-marshallers name de-marshaller)
                  (set! marshallers (append marshallers (list (list type-identifier name marshaller))))
                  #t)
              (let ((B (car before)))
                (letrec ((adder (lambda (L)
                                  (if (null? L)
                                      (begin
                                        (hash-table-put! de-marshallers name de-marshaller)
                                        (list (list type-identifier name marshaller)))
                                      (let ((e (car L)))
                                        (if (or (eq? B (r-name e)) (eq? B (r-type-identifier e)))
                                            (begin
                                              (hash-table-put! de-marshallers name de-marshaller)
                                              (cons (list type-identifier name marshaller) L))
                                            (cons (car L) (adder (cdr L)))))))))
                  (set! marshallers (adder marshallers))
                  #t))))
        
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        ;;;; Storage
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        
        (define marshallers    (list))
        (define de-marshallers (make-hash-table))
        
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        ;;;; Exported functions
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        
        ;;;; * rpc-marshal
        (define (rpc-marshal object)
          
          (define (marshal L)
            (if (null? L)
                (error (format "Don't know how to marshal object ~s~%" object))
                (let ((e (car L)))
                  (if ((r-type-identifier e) object)
                      (list (r-name e) ((r-marshaller e) object))
                      (marshal (cdr L))))))
          
          (marshal marshallers))
        
        
        ;;;; * rpc-de-marshal
        (define (rpc-de-marshal marshalled-object)
          (let ((de-marshal (hash-table-get de-marshallers (car marshalled-object) (lambda () #f))))
            (if (eq? de-marshal #f)
                (error (format "Don't know how to de-marshal ~s~%" marshalled-object))
                (de-marshal (cadr marshalled-object)))))
          
        
        ;;;; * rpc-register-atom-marshaller
        (define-syntax rpc-register-atom-marshaller
          (syntax-rules ()
            ((_ type-identifier ...)
             (begin
               (rpc-register-marshaller type-identifier identity identity)
               ...))))
        
        ;;;; * rpc-register-marshaller
        (define-syntax rpc-register-marshaller
          (syntax-rules ()
            ((_ type-identifier marshaller de-marshaller)
             (internal-rpc-register-marshaller 'type-identifier type-identifier marshaller de-marshaller))
            ((_ type-identifier marshaller de-marshaller before-type-identifier)
             (internal-rpc-register-marshaller 'type-identifier type-identifier marshaller de-marshaller before-type-identifier))
            ))
        
        ;;;; * any->string
        (define (any->string any)
          (let ((fh (open-output-string)))
            (write (rpc-marshal any) fh)
            (let ((S (get-output-string fh)))
              (close-output-port fh)
              S)))
        
        ;;;; * string->any
        (define (string->any str)
          (let ((fh (open-input-string str)))
            (let ((R (rpc-de-marshal (read fh))))
              (close-input-port fh)
              R)))
        
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        ;;;; Default marshallers
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        
        (rpc-register-atom-marshaller symbol?
                                      string?
                                      bytes?
                                      boolean?
                                      integer?
                                      number?
                                      char?
                                      time?)
                                      
        (define (pre-zero2 n)
          (if (< n 10)
              (string-append "0" (integer->string n))
              (integer->string n)))
        
        (define string->integer string->number)
        (define integer->string number->string)

        (rpc-register-marshaller date?
                                 (lambda (dt)
                                   (date->string dt "~Y~m~dT~H~M~S"))
                                 (lambda (dt)
                                   (string->date dt "~Y~m~dT~H~M~S")))

        (rpc-register-marshaller srfi:date?
                                 (lambda (dt)
                                   (date->string dt "~4"))
                                 (lambda (dt)
                                   (string->date dt "~Y-~m-~dT~H:~M:~S~z")))
        
        (rpc-register-marshaller list? 
                                 (lambda (L)
                                   (map (lambda (obj) (rpc-marshal obj)) L))
                                 (lambda (L)
                                   (map (lambda (obj) (rpc-de-marshal obj)) L))
                                 pair?)   ;;;; list before pair
        
        (rpc-register-marshaller pair?
                                 (lambda (P)
                                   (list (rpc-marshal (car P)) (rpc-marshal (cdr P))))
                                 (lambda (L)
                                   (cons (rpc-de-marshal (car L)) (rpc-de-marshal (cadr L)))))
        
        (rpc-register-marshaller vector?
                                 (lambda (V)
                                   (map (lambda (obj) (rpc-marshal obj)) (vector->list V)))
                                 (lambda (L)
                                   (apply vector (map (lambda (obj) (rpc-de-marshal obj)) L))))
        
        (rpc-register-marshaller hash-table-equal?
                                 (lambda (H)
                                   (hash-table-map H (lambda (key val)
                                                       (list (rpc-marshal key) (rpc-marshal val)))))
                                 (lambda (L)
                                   (let ((H (make-hash-table 'equal)))
                                     (for-each (lambda (h)
                                                 (hash-table-put! H (rpc-de-marshal (car h)) (rpc-de-marshal (cadr h))))
                                               L)
                                     H))
                                 hash-table?) ;;;; hash-table-equal? before hash-table?
        
        (rpc-register-marshaller hash-table?
                                 (lambda (H)
                                   (hash-table-map H (lambda (key val)
                                                       (list (rpc-marshal key) (rpc-marshal val)))))
                                 (lambda (L)
                                   (let ((H (make-hash-table)))
                                     (for-each (lambda (h)
                                                 (hash-table-put! H (rpc-de-marshal (car h)) (rpc-de-marshal (cadr h))))
                                               L)
                                     H)))
        
        (rpc-register-marshaller procedure-with-name?
                                 object-name
                                 eval)
        
        );;;; module-end