add prop:struct-info

svn: r18730

collects/scheme/private/struct-info.ss

@@ -8,7 +8,18 @@
   (#%provide make-struct-info
              struct-info?
              extract-struct-info
-             struct:struct-info)
+             struct:struct-info
+             prop:struct-info)
+
+  (define-values (prop:struct-info has-struct-info-prop? struct-info-prop-ref)
+    (make-struct-type-property 'struct-info
+                               (lambda (v type-info)
+                                 (if (and (procedure? v)
+                                          (procedure-arity-includes? v 1))
+                                     v
+                                     (raise-type-error 'guard-for-prop:struct-info
+                                                       "procedure (arity 1)"
+                                                       v)))))
   
   (define-values (struct:struct-info make-struct-info struct-info-rec?
                                      struct-info-ref struct-info-set!)
@@ -31,21 +42,34 @@
 
   (define-values (extract-struct-info)
     (lambda (si)
-      (if (struct-info-rec? si)
+      (cond
-          (let ([p (struct-info-ref si 0)])
+       [(struct-info-rec? si)
-            (let ([v (p)])
+        (let ([p (struct-info-ref si 0)])
-              (if (struct-declaration-info? v)
+          (let ([v (p)])
-                  v
+            (if (struct-declaration-info? v)
-                  (error 'extract-struct-info
+                v
-                         "struct-info procedure result not properly formed: ~e"
+                (error 'extract-struct-info
-                         v))))
+                       "struct-info procedure result not properly formed: ~e"
-          (if (set!-transformer? si)
+                       v))))]
-              (extract-struct-info (set!-transformer-procedure si))
+       [(has-struct-info-prop? si)
-              si))))
+        (let ([v ((struct-info-prop-ref si) si)])
+          (if (struct-declaration-info? v)
+              v
+              (error 'extract-struct-info
+                     "prop:struct-info procedure result not properly formed: ~e"
+                     v)))]
+       [(set!-transformer? si)
+        (extract-struct-info (set!-transformer-procedure si))]
+       [(struct-declaration-info? si) si]
+       [else (raise-type-error 'extract-struct-info
+                               "struct-info"
+                               si)])))
 
   (define-values (struct-info?)
     (lambda (si)
       (or (struct-info-rec? si)
+          (and (has-struct-info-prop? si)
+               (not (struct-type? si)))
           (struct-declaration-info? si)
           (and (set!-transformer? si)
                (struct-info-rec? (set!-transformer-procedure si))))))

collects/scribblings/reference/struct.scrbl

@@ -318,7 +318,7 @@ Creates a new structure type property and returns three values:
 
 If the optional @scheme[guard] is supplied as a procedure, it is
 called by @scheme[make-struct-type] before attaching the property to a
-new structure type. The @scheme[guard-proc] must accept two arguments:
+new structure type. The @scheme[guard] must accept two arguments:
 a value for the property supplied to @scheme[make-struct-type], and a
 list containing information about the new structure type. The list
 contains the values that @scheme[struct-type-info] would return for
@@ -596,14 +596,17 @@ encapsulated procedure must return):
 
 ]
 
-Instead of this direct representation, the representation can
+Instead of this direct representation, the representation can be a
-be a structure created by @scheme[make-struct-info] (or an instance of
+structure created by @scheme[make-struct-info] (or an instance of a
-a subtype of @scheme[struct:struct-info]), which encapsulates a
+subtype of @scheme[struct:struct-info]), which encapsulates a
 procedure that takes no arguments and returns a list of six
-elements. Finally, the representation can be an instance of a
+elements. Alternately, the representation can be a structure whose
-structure type derived from @scheme[struct:struct-info] that also
+type has the @scheme[prop:struct-info] @tech{structure type property}.
-implements @scheme[prop:procedure], and where the instance is further
+Finally, the representation can be an instance of a structure type
-is wrapped by @scheme[make-set!-transformer].
+derived from @scheme[struct:struct-info] or with the
+@scheme[prop:struct-info] property that also implements
+@scheme[prop:procedure], and where the instance is further is wrapped
+by @scheme[make-set!-transformer].
 
 Use @scheme[struct-info?] to recognize all allowed forms of the
 information, and use @scheme[extract-struct-info] to obtain a list
@@ -626,9 +629,10 @@ type.
 
 Returns @scheme[#t] if @scheme[v] is either a six-element list with
 the correct shape for representing structure-type information, a
-procedure encapsulated by @scheme[make-struct-info], or a structure
+procedure encapsulated by @scheme[make-struct-info], a structure with
-type derived from @scheme[struct:struct-info] and wrapped with
+the @scheme[prop:struct-info] property, or a structure type derived
-@scheme[make-set!-transformer].}
+from @scheme[struct:struct-info] or with @scheme[prop:struct-info] and
+wrapped with @scheme[make-set!-transformer].}
 
 @defproc[(checked-struct-info? [v any/c]) boolean?]{
 
@@ -657,6 +661,13 @@ mostly useful for creating structure subtypes. The structure type
 includes a guard that checks an instance's first field in the same way
 as @scheme[make-struct-info].}
 
+@defthing[prop:struct-info struct-type-property?]{
+
+The @tech{structure type property} for creating new structure types
+like @scheme[struct:struct-info]. The property value must a procedure
+of one argument that takes an instance structure and returns
+structure-type information in list form.}
+
 @; ----------------------------------------------------------------------
 
 @close-eval[struct-eval]

collects/tests/mzscheme/struct.ss

@@ -977,4 +977,32 @@
 
 ;; ----------------------------------------
 
+(require (for-syntax scheme/struct-info))
+
+(let ()
+  (define-struct a (x y))
+  (define-syntax foo (make-struct-info
+                      (lambda ()
+                        (list #'struct:a #'make-a #'a?
+                              (list #'a-y #'a-x)
+                              (list #f #f)
+                              #f))))
+  (define-syntax foo2 (let ()
+                        (define-struct si (pred)
+                          #:property 
+                          prop:struct-info
+                          (lambda (v)
+                            (list #'struct:a #'make-a (si-pred v)
+                                  (list #'a-y #'a-x)
+                                  (list #f #f)
+                                  #f)))
+                        (make-si #'a?)))
+  (test (list 1 2) 'match (match (make-a 1 2)
+                            [(struct foo (x y)) (list x y)]))
+  (test (list 1 2) 'match (match (make-a 1 2)
+                            [(struct foo2 (x y)) (list x y)])))
+                              
+
+;; ----------------------------------------
+
 (report-errs)