From 783e309b4d9da9f5f4debf48a02b66b4618c04fc Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 30 Apr 2010 06:21:02 -0600
Subject: [PATCH] add serializable-struct

---
 collects/racket/serialize.rkt                 | 59 ++++++++++++---
 .../scribblings/reference/serialization.scrbl | 72 +++++++++++--------
 2 files changed, 94 insertions(+), 37 deletions(-)

diff --git a/collects/racket/serialize.rkt b/collects/racket/serialize.rkt
index 4849b2beec..f839b30e8f 100644
--- a/collects/racket/serialize.rkt
+++ b/collects/racket/serialize.rkt
@@ -5,13 +5,15 @@
                        racket/struct-info))
 
   (provide (all-from-out "private/serialize.ss")
+           serializable-struct
+           serializable-struct/versions
            define-serializable-struct
            define-serializable-struct/versions)
 
   (define-syntax (define-serializable-struct/versions/derived stx)
     (syntax-case stx ()
       ;; First check `id/sup':
-      [(_ orig-stx id/sup . _)
+      [(_ orig-stx make-prefix? id/sup . _)
        (not (or (identifier? #'id/sup)
                 (syntax-case #'id/sup ()
                   [(id sup) (and (identifier? #'id) 
@@ -22,11 +24,11 @@
        ;; Not valid, so let `define-struct/derived' complain:
        #'(define-struct/derived orig-stx id/sup ())]
       ;; Check version:
-      [(_ orig-stx id/sup vers . _)
+      [(_ orig-stx make-prefix? id/sup vers . _)
        (not (exact-nonnegative-integer? (syntax-e #'vers)))
        (raise-syntax-error #f "expected a nonnegative exact integer for a version" #'orig-stx #'vers)]
       ;; Main case:
-      [(_ orig-stx id/sup vers (field ...) ([other-vers make-proc-expr cycle-make-proc-expr] ...) 
+      [(_ orig-stx make-prefix? id/sup vers (field ...) ([other-vers make-proc-expr cycle-make-proc-expr] ...) 
           prop ...)
        (let* ([id (if (identifier? #'id/sup)
                       #'id/sup
@@ -35,10 +37,22 @@
                               #f
                               (extract-struct-info (syntax-local-value (cadr (syntax->list #'id/sup)))))]
               [fields (syntax->list #'(field ...))]
-              [maker (datum->syntax id
-                                    (string->symbol
-                                     (format "make-~a" (syntax-e id)))
-                                    id)]
+              [given-maker (let loop ([props (syntax->list #'(prop ...))])
+                             (cond
+                              [(null? props) #f]
+                              [(null? (cdr props)) #f]
+                              [(or (eq? (syntax-e (car props)) '#:constructor-name)
+                                   (eq? (syntax-e (car props)) '#:extra-constructor-name))
+                               (and (identifier? (cadr props))
+                                    (cadr props))]
+                              [else (loop (cdr props))]))]
+              [maker (or given-maker
+                         (if (syntax-e #'make-prefix?)
+                             (datum->syntax id
+                                            (string->symbol
+                                             (format "make-~a" (syntax-e id)))
+                                            id)
+                             id))]
               [getters (map (lambda (field)
                               (datum->syntax
                                id
@@ -103,6 +117,10 @@
                id/sup
                (field ...)
                prop ...
+               #,@(if (or given-maker
+                          (syntax-e #'make-prefix?))
+                      null
+                      (list #'#:constructor-name id))
                #:property prop:serializable
                (make-serialize-info
                 ;; The struct-to-vector function: --------------------
@@ -203,14 +221,37 @@
   (define-syntax (define-serializable-struct/versions stx)
     (syntax-case stx ()
       [(_ . rest)
-       #`(define-serializable-struct/versions/derived #,stx . rest)]))
+       #`(define-serializable-struct/versions/derived #,stx #t . rest)]))
+
+  (define-syntax (serializable-struct/versions stx)
+    (syntax-case stx ()
+      [(_ id super-id . rest)
+       (and (identifier? #'id)
+            (identifier? #'super-id))
+       #`(define-serializable-struct/versions/derived #,stx #f (id super-id) . rest)]
+      [(_ id (field ...) . rest)
+       (identifier? #'id)
+       #`(define-serializable-struct/versions/derived #,stx #f id (field ...) . rest)]))
   
   (define-syntax (define-serializable-struct stx)
     (syntax-case stx ()
       [(_ id/sup (field ...) prop ...)
-       #`(define-serializable-struct/versions/derived #,stx
+       #`(define-serializable-struct/versions/derived #,stx #t
            id/sup 0 (field ...) () prop ...)]
       [(_ . rest)
        #`(define-struct/derived #,stx . rest)]))
 
+  (define-syntax (serializable-struct stx)
+    (syntax-case stx ()
+      [(_ id super-id (field ...) prop ...)
+       (and (identifier? #'id)
+            (identifier? #'super-id))
+       #`(define-serializable-struct/versions/derived #,stx #f
+           (id super-id) 0 (field ...) () prop ...)]
+      [(_ id (field ...) prop ...)
+       (and (identifier? #'id)
+            (identifier? #'super-id))
+       #`(define-serializable-struct/versions/derived #,stx #f
+           id 0 (field ...) () prop ...)]))
+
 )
diff --git a/collects/scribblings/reference/serialization.scrbl b/collects/scribblings/reference/serialization.scrbl
index e1e32b8944..d17e6d5dd3 100644
--- a/collects/scribblings/reference/serialization.scrbl
+++ b/collects/scribblings/reference/serialization.scrbl
@@ -33,8 +33,8 @@ The following kinds of values are serializable:
 
 @itemize[
 
- @item{structures created through @scheme[define-serializable-struct] or
-       @scheme[define-serializable-struct/version], or more generally
+ @item{structures created through @scheme[serializable-struct] or
+       @scheme[serializable-struct/versions], or more generally
        structures with the @scheme[prop:serializable] property (see
        @scheme[prop:serializable] for more information);}
 
@@ -338,10 +338,10 @@ exception to disallow the @scheme[dynamic-require].}
 
 @; ----------------------------------------------------------------------
 
-@defform[(define-serializable-struct id-maybe-super (field ...)
-                                      struct-option ...)]{
+@defform[(serializable-struct id maybe-super (field ...)
+                              struct-option ...)]{
 
-Like @scheme[define-struct], but instances of the structure type are
+Like @scheme[struct], but instances of the structure type are
 serializable with @scheme[serialize].  This form is allowed only at
 the top level or in a module's top level (so that deserialization
 information can be found later).
@@ -350,17 +350,16 @@ Serialization only supports cycles involving the created structure
 type when all fields are mutable (or when the cycle can be broken
 through some other mutable value).
 
-In addition to the bindings generated by @scheme[define-struct],
-@scheme[define-serializable-struct] binds
+In addition to the bindings generated by @scheme[struct],
+@scheme[serializable-struct] binds
 @schemeidfont{deserialize-info:}@scheme[_id]@schemeidfont{-v0} to
 deserialization information. Furthermore, in a module context, it
 automatically @scheme[provide]s this binding.
 
-The @scheme[define-serializable-struct] form enables the construction
-of structure instances from places where
-@schemeidfont{make}@scheme[id] is not accessible, since
-deserialization must construct instances. Furthermore,
-@scheme[define-serializable-struct] provides limited access to field
+The @scheme[serializable-struct] form enables the construction of
+structure instances from places where @scheme[id] is not accessible,
+since deserialization must construct instances. Furthermore,
+@scheme[serializable-struct] provides limited access to field
 mutation, but only for instances generated through the deserialization
 information bound to
 @schemeidfont{deserialize-info:}@scheme[_id]@schemeidfont{-v0}. See
@@ -368,9 +367,9 @@ information bound to
 
 The @scheme[-v0] suffix on the deserialization enables future
 versioning on the structure type through
-@scheme[define-serializable-struct/version].
+@scheme[serializable-struct/version].
 
-When a supertype is supplied in @scheme[id-maybe-super] is supplied,
+When a supertype is supplied in @scheme[maybe-super] is supplied,
 compile-time information bound to the supertype identifier must
 include all of the supertype's field accessors. If any field mutator
 is missing, the structure type will be treated as immutable for the
@@ -379,20 +378,28 @@ structure type cannot be handled by the deserializer).
 
 @examples[
 #:eval ser-eval
-(define-serializable-struct point (x y))
-(point-x (deserialize (serialize (make-point 1 2))))
+(serializable-struct point (x y))
+(point-x (deserialize (serialize (point 1 2))))
 ]}
 
 @; ----------------------------------------------------------------------
 
-@defform/subs[(define-serializable-struct/versions id-maybe-super vers (field ...)
-                                                   (other-version-clause ...)
-                                                   struct-option ...)
+@defform[(define-serializable-struct id-maybe-super (field ...)
+                                      struct-option ...)]{
+
+Like @racket[serializable-struct], but with the supertype syntax and
+default constructor name of @racket[define-struct].}
+
+@; ----------------------------------------------------------------------
+
+@defform/subs[(serializable-struct/versions id-maybe-super vers (field ...)
+                                            (other-version-clause ...)
+                                            struct-option ...)
               ([other-version-clause (other-vers make-proc-expr 
                                                  cycle-make-proc-expr)])]{
 
-Like @scheme[define-serializable-struct], but the generated
-deserializer binding is
+Like @scheme[serializable-struct], but the generated deserializer
+binding is
 @schemeidfont{deserialize-info:}@scheme[_id]@schemeidfont{-v}@scheme[vers]. In
 addition,
 @schemeidfont{deserialize-info:}@scheme[_id]@schemeidfont{-v}@scheme[other-vers]
@@ -410,35 +417,44 @@ instance of @scheme[id] and copies its field values into @scheme[x].
 
 @examples[
 #:eval ser-eval
-(define-serializable-struct point (x y) #:mutable #:transparent)
-(define ps (serialize (make-point 1 2)))
+(serializable-struct point (x y) #:mutable #:transparent)
+(define ps (serialize (point 1 2)))
 (deserialize ps)
 
-(define x (make-point 1 10))
+(define x (point 1 10))
 (set-point-x! x x)
 (define xs (serialize x))
 (deserialize xs)
 
-(define-serializable-struct/versions point 1 (x y z)
+(serializable-struct/versions point 1 (x y z)
    ([0 
      (code:comment @#,t{Constructor for simple v0 instances:})
-     (lambda (x y) (make-point x y 0))
+     (lambda (x y) (point x y 0))
      (code:comment @#,t{Constructor for v0 instance in a cycle:})
      (lambda ()
-       (let ([p0 (make-point #f #f 0)])
+       (let ([p0 (point #f #f 0)])
          (values
            p0
            (lambda (p)
              (set-point-x! p0 (point-x p))
              (set-point-y! p0 (point-y p))))))])
    #:mutable #:transparent)
-(deserialize (serialize (make-point 4 5 6)))
+(deserialize (serialize (point 4 5 6)))
 (deserialize ps)
 (deserialize xs)
 ]}
 
 @; ----------------------------------------------------------------------
 
+@defform[(define-serializable-struct/versions id-maybe-super vers (field ...)
+                                              (other-version-clause ...)
+                                              struct-option ...)]{
+Like @racket[serializable-struct/versions], but with the supertype syntax and
+default constructor name of @racket[define-struct].}
+}
+
+@; ----------------------------------------------------------------------
+
 @defproc[(make-deserialize-info [make procedure?]
                                 [cycle-make (-> (values any/c procedure?))])
          any]{