.

original commit: 69d9b669b4c6bf3a02f0c0a3a506dd4f44eeeb98

collects/mzlib/class.ss

@@ -4,12 +4,12 @@
   ;;  which provides extra (private) functionality to contract.ss.
   (require "private/class-internal.ss")
   
-  (provide class
-	   class*
+  (provide class class* class/derived
+	   define-serializable-class define-serializable-class*
            class?
 	   mixin
            interface interface?
-	   object% object?
+	   object% object? externalizable<%>
            object=?
 	   new make-object instantiate
 	   send send/apply send* class-field-accessor class-field-mutator with-method
@@ -37,4 +37,5 @@
 	   field init init-field
 	   rename-super rename-inner inherit
 	   this super inner
-	   super-make-object super-instantiate super-new))
+	   super-make-object super-instantiate super-new
+	   inspect))

collects/mzlib/serialize.ss

@@ -2,7 +2,8 @@
   (require-for-syntax (lib "struct.ss" "syntax"))
   (require (lib "moddep.ss" "syntax")
 	   (lib "etc.ss")
-	   (lib "list.ss"))
+	   (lib "list.ss")
+	   "private/serialize-structs.ss")
 
   (provide define-serializable-struct
 	   define-serializable-struct/versions
@@ -19,9 +20,6 @@
 	   serialize
 	   deserialize)
 
-  (define-struct serialize-info (vectorizer deserialize-id can-cycle? dir))
-  (define-struct deserialize-info (maker cycle-maker))
-
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;; define-serializable-struct
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -413,9 +411,6 @@
   ;; serialize
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-  (define-values (prop:serializable serializable-struct? serializable-info)
-    (make-struct-type-property 'serializable #f))
-
   (define (serializable? v)
     (or (serializable-struct? v)
 	(boolean? v)

collects/mzlib/struct.ss

@@ -2,11 +2,16 @@
 ;; by Jacob Matthews (and others)
 
 (module struct mzscheme
-  (provide copy-struct make-->vector)
+  (provide copy-struct 
+	   define-struct/properties
+	   make-->vector)
   (require-for-syntax (lib "struct.ss" "syntax")
 		      "list.ss"
                       (lib "stx.ss" "syntax"))
 
+  ;; ------------------------------------------------------------
+  ;; copy-struct
+
   ;; copy-struct expands to `do-copy-struct' to delay the expansion
   ;;  in an internal-definition context. (The `begin0' wrapper
   ;;  effectively declares the form to be an expression.)
@@ -71,7 +76,103 @@
 			       (lambda (field) (or (new-binding-for field) #`(#,field the-struct)))
 			       (reverse accessors)))
 			  (raise-type-error '_  #,(format "struct:~a" (syntax-object->datum #'info)) the-struct))))))]))]))
+
+  ;; --------------------------------------------------
+  ;; define-struct/properties
   
+  ;; Used at run time:
+  (define (check-prop v)
+    (unless (struct-type-property? v)
+      (raise-type-error
+       'define-struct/properties
+       "struct-type property"
+       v))
+    v)
+    
+  ;; This compile-time proc fills in the crucial part of the expansion.
+  ;; Because it's called through a syntax trampoline, the arguments have to
+  ;; to be packaged as a syntax object.
+  (define-for-syntax (make-make-make-struct-type props+insp-stx)
+    (with-syntax ([(([prop expr] ...) inspector) props+insp-stx])
+      (lambda (orig-stx name-stx defined-name-stxes super-info)
+	#`(make-struct-type '#,name-stx 
+			    #,(and super-info (list-ref super-info 0))
+			    #,(/ (- (length defined-name-stxes) 3) 2)
+			    0 #f
+			    (list
+			     (cons (check-prop prop)
+				   expr)
+			     ...)
+			    inspector))))
+  
+  ;; The main macro:
+  (define-syntax (define-struct/properties stx)    
+
+    ;; Start paring. Exploit `parse-define-struct' as much as possible.
+    (define (parse-at-main)
+      (syntax-case stx ()
+	[(_ id/sup fields . rest)
+	 ;; Check initial part:
+	 (let-values ([(id sup-id fields _) 
+		       (parse-define-struct #`(_ id/sup fields) stx)])
+	   (parse-at-props id sup-id fields #'rest))]
+	[_
+	 ;; Not even right up to define-struct, so let the
+	 ;;  simple parser report the problem:
+	 (parse-define-struct stx stx)]))
+    
+    ;; So far, so good. Parse props.
+    (define (parse-at-props id sup-id fields rest)
+      (syntax-case rest ()
+	[(([prop expr] ...) . rrest)
+	 (parse-at-inspector id sup-id fields (stx-car rest) (stx-cdr rest))]
+	[((bad ...) . rest)
+	 (for-each (lambda (bad)
+		     (syntax-case bad ()
+		       [(a b) 'ok]
+		       [_ (raise-syntax-error
+			   #f
+			   "expected a parenthesized property--value pairing"
+			   stx
+			   bad)]))
+		   (syntax->list #'(bad ...)))]
+	[(bad . rest)
+	 (raise-syntax-error
+	  #f
+	  "expected a parenthesized sequence of property--value pairings"
+	  stx
+	  #'bad)]
+	[_
+	 (raise-syntax-error
+	  #f
+	  "expected a parenthesized sequence of property--value pairings after fields"
+	  stx)]))
+
+    ;; Finally, parse optional inspector expr, again exploting
+    ;;  `parse-define-struct'.
+    (define (parse-at-inspector id sup-id fields props rest)
+      (let-values ([(_ __ ___ inspector-stx)
+		    (parse-define-struct #`(ds id () #,@rest) stx)])
+	(build-result id sup-id fields props inspector-stx)))
+
+    ;; Build the result using `generate-struct-declaration', which 
+    ;;  sometimes needs the `continue-ds/p' trampoline to eventually get
+    ;;  to make-make-make-struct-type.
+    (define (build-result id sup-id fields props inspector)
+      (let ([props+insp #`(#,props #,inspector)])
+	(generate-struct-declaration stx
+				     id sup-id fields
+				     (syntax-local-context)
+				     (make-make-make-struct-type props+insp)
+				     #'continue-ds/p props+insp)))
+    
+    (parse-at-main))
+      
+  (define-syntax (continue-ds/p stx)
+    (generate-delayed-struct-declaration stx make-make-make-struct-type))
+
+  ;; ------------------------------------------------------------
+  ;; make->vector
   
   (define-syntax (make-->vector stx)
     (syntax-case stx ()