Guile `make-record-type' supports non-generative definition

* module/ice-9/boot-9.scm (prefab-record-types): New definition.
  (make-record-type): Add #:uid keyword.
* test-suite/tests/records.test ("records"): Add tests.
* doc/ref/api-data.texi (Records): Document #:uid

doc/ref/api-data.texi

@@ -8631,7 +8631,7 @@ promise that records are disjoint with other Scheme types.
 @end deffn
 
 @deffn {Scheme Procedure} make-record-type type-name field-names [print] @
-       [#:final?=@code{#t}] [parent=@code{#f}]
+       [#:final?=@code{#t}] [#:parent=@code{#f}] [#:uid=@code{#f}]
 Create and return a new @dfn{record-type descriptor}.
 
 @var{type-name} is a string naming the type.  Currently it's only used
@@ -8659,6 +8659,18 @@ work on any instance of a subtype.
 Allowing record subtyping has a small amount of overhead.  To avoid this
 overhead, declare the record type as @dfn{final} by passing
 @code{#:final? #t}.  Record types in Guile are final by default.
+
+@cindex prefab record types
+@cindex record types, prefab
+@cindex record types, nongenerative
+Generally speaking, calling @code{make-record-type} returns a fresh
+record type; it @emph{generates} new record types.  However sometimes
+you only want to define a record type if one hasn't been defined
+already.  For a @emph{nongenerative} record type definition, pass a
+symbol as the @code{#:uid} keyword parameter.  If a record with the
+given @var{uid} was already defined, it will be returned instead.  The
+type name, fields, parent (if any), and so on for the previously-defined
+type must be compatible.
 @end deffn
 
 @deffn {Scheme Procedure} record-constructor rtd

module/ice-9/boot-9.scm

@@ -1233,8 +1233,11 @@ VALUE."
     (error 'not-a-record-type rtd))
   (struct-ref rtd (+ 4 vtable-offset-user)))
 
+(define prefab-record-types
+  (make-hash-table))
+
 (define* (make-record-type type-name fields #:optional printer #:key
-                           (final? #t) parent)
+                           (final? #t) parent uid)
   ;; Pre-generate constructors for nfields < 20.
   (define-syntax make-constructor
     (lambda (x)
@@ -1338,8 +1341,22 @@ VALUE."
      (else
       (error "expected a symbol for record type name" type-name))))
 
-  (define rtd
-    (make-struct/no-tail
+  (define properties
+    (if final? '((final? . #t)) '()))
+
+  (cond
+   ((and uid (hashq-ref prefab-record-types uid))
+    => (lambda (rtd)
+         (unless (and (equal? (record-type-name rtd) name-sym)
+                      (equal? (record-type-fields rtd) computed-fields)
+                      (not printer)
+                      (equal? (record-type-properties rtd) properties)
+                      (equal? (record-type-parents rtd) parents))
+           (error "prefab record type declaration incompatible with previous"
+                  rtd))
+         rtd))
+   (else
+    (let ((rtd (make-struct/no-tail
                 record-type-vtable
                 (make-struct-layout
                  (apply string-append
@@ -1348,17 +1365,23 @@ VALUE."
                 name-sym
                 computed-fields
                 #f                      ; Constructor initialized below.
-     (if final? '((final? . #t)) '())
-     parents))
+                properties
+                parents)))
 
       (struct-set! rtd (+ vtable-offset-user 2)
                    (make-constructor rtd (length computed-fields)))
 
-  ;; Temporary solution: Associate a name to the record type descriptor
-  ;; so that the object system can create a wrapper class for it.
+      ;; Temporary solution: Associate a name to the record type
+      ;; descriptor so that the object system can create a wrapper
+      ;; class for it.
       (set-struct-vtable-name! rtd name-sym)
 
-  rtd)
+      (when uid
+        (unless (symbol? uid)
+          (error "UID for prefab record type should be a symbol" uid))
+        (hashq-set! prefab-record-types uid rtd))
+
+      rtd))))
 
 (define record-constructor
   (case-lambda

test-suite/tests/records.test

@@ -132,4 +132,26 @@
         ((record-accessor b 'u) ((record-constructor c) 1 2 3 4)))
 
       (pass-if-equal "c accessor on c" 3
-        ((record-accessor c 'w) ((record-constructor c) 1 2 3 4))))))
+        ((record-accessor c 'w) ((record-constructor c) 1 2 3 4)))))
+
+  (with-test-prefix "prefab types"
+    (let ()
+      (define uid 'ANhUpf2WpNnF2XIVLxq@IkavIc5wbqe8)
+      (define a (make-record-type 'a '(s t) #:uid uid))
+      (define b (make-record-type 'b '() #:final? #f))
+
+      (pass-if (eq? a (make-record-type 'a '(s t) #:uid uid)))
+      (pass-if-exception "different name" '(misc-error . "incompatible")
+        (make-record-type 'b '(s t) #:uid uid))
+      (pass-if-exception "different fields" '(misc-error . "incompatible")
+        (make-record-type 'a '(u v) #:uid uid))
+      (pass-if-exception "fewer fields" '(misc-error . "incompatible")
+        (make-record-type 'a '(s) #:uid uid))
+      (pass-if-exception "more fields" '(misc-error . "incompatible")
+        (make-record-type 'a '(s t u) #:uid uid))
+      (pass-if-exception "adding a parent" '(misc-error . "incompatible")
+        (make-record-type 'a '(s t) #:parent b #:uid uid))
+      (pass-if-exception "specifying a printer" '(misc-error . "incompatible")
+        (make-record-type 'a '(s t) pk #:uid uid))
+      (pass-if-exception "non-final" '(misc-error . "incompatible")
+        (make-record-type 'a '(s t) #:final? #f #:uid uid)))))