add structure-type sealing

The predicate for a seald structure type can be faster than a
predicate for a non-sealed structure type, and Chez Scheme takes
advantage of that opportunity.

The BC JIT could be improved to take advanatge of sealed structure
types, but it isn't.

This commit also fixes CS checking of a supertype for certain shapes
of prefab struct-type declarations.

.makefile

@@ -344,7 +344,7 @@ RACKET_FOR_BOOTFILES = $(RACKET)
 RACKET_FOR_BUILD = $(RACKET)
 
 # This branch name changes each time the pb boot files are updated:
-PB_BRANCH == circa-8.0.0.6-3
+PB_BRANCH == circa-8.0.0.7-1
 PB_REPO = https://github.com/racket/pb
 
 # Alternative source for Chez Scheme boot files, normally set by

Makefile

@@ -47,7 +47,7 @@ RACKETCS_SUFFIX =
 RACKET =
 RACKET_FOR_BOOTFILES = $(RACKET)
 RACKET_FOR_BUILD = $(RACKET)
-PB_BRANCH = circa-8.0.0.6-3
+PB_BRANCH = circa-8.0.0.7-1
 PB_REPO = https://github.com/racket/pb
 EXTRA_REPOS_BASE =
 CS_CROSS_SUFFIX =
@@ -309,18 +309,18 @@ maybe-fetch-pb-as-is:
 	echo done
 fetch-pb-from:
 	mkdir -p racket/src/ChezScheme/boot
-	if [ ! -d racket/src/ChezScheme/boot/pb ] ; 	  then git clone -q -b circa-8.0.0.6-3 $(PB_REPO) racket/src/ChezScheme/boot/pb ; 	  else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-8.0.0.6-3:remotes/origin/circa-8.0.0.6-3 ; fi
+	if [ ! -d racket/src/ChezScheme/boot/pb ] ; 	  then git clone -q -b circa-8.0.0.7-1 $(PB_REPO) racket/src/ChezScheme/boot/pb ; 	  else cd racket/src/ChezScheme/boot/pb && git fetch -q origin circa-8.0.0.7-1:remotes/origin/circa-8.0.0.7-1 ; fi
-	cd racket/src/ChezScheme/boot/pb && git checkout -q circa-8.0.0.6-3
+	cd racket/src/ChezScheme/boot/pb && git checkout -q circa-8.0.0.7-1
 pb-fetch:
 	$(MAKE) fetch-pb EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" PB_REPO="$(PB_REPO)"
 pb-build:
 	cd racket/src/ChezScheme && racket rktboot/main.rkt --machine pb
 pb-stage:
-	cd racket/src/ChezScheme/boot/pb && git branch circa-8.0.0.6-3
+	cd racket/src/ChezScheme/boot/pb && git branch circa-8.0.0.7-1
-	cd racket/src/ChezScheme/boot/pb && git checkout circa-8.0.0.6-3
+	cd racket/src/ChezScheme/boot/pb && git checkout circa-8.0.0.7-1
 	cd racket/src/ChezScheme/boot/pb && git add . && git commit --amend -m "new build"
 pb-push:
-	cd racket/src/ChezScheme/boot/pb && git push -u origin circa-8.0.0.6-3
+	cd racket/src/ChezScheme/boot/pb && git push -u origin circa-8.0.0.7-1
 win-cs-base:
 	IF "$(RACKET_FOR_BUILD)" == "" $(MAKE) win-bc-then-cs-base SETUP_BOOT_MODE=--boot WIN32_BUILD_LEVEL=bc PLAIN_RACKET=racket\racketbc DISABLE_STATIC_LIBS="$(DISABLE_STATIC_LIBS)" EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" JOB_OPTIONS="$(JOB_OPTIONS)" PLT_SETUP_OPTIONS="$(PLT_SETUP_OPTIONS)" RACKETBC_SUFFIX="$(RACKETBC_SUFFIX)" RACKETCS_SUFFIX="$(RACKETCS_SUFFIX)"
 	IF not "$(RACKET_FOR_BUILD)" == "" $(MAKE) win-just-cs-base SETUP_BOOT_MODE=--chain DISABLE_STATIC_LIBS="$(DISABLE_STATIC_LIBS)" EXTRA_REPOS_BASE="$(EXTRA_REPOS_BASE)" JOB_OPTIONS="$(JOB_OPTIONS)" PLT_SETUP_OPTIONS="$(PLT_SETUP_OPTIONS)" RACKETCS_SUFFIX="$(RACKETCS_SUFFIX)" RACKET_FOR_BUILD="$(RACKET_FOR_BUILD)"

pkgs/base/info.rkt

@@ -14,7 +14,7 @@
 
 ;; In the Racket source repo, this version should change only when
 ;; "racket_version.h" changes:
-(define version "8.0.0.6")
+(define version "8.0.0.7")
 
 (define deps `("racket-lib"
                ["racket" #:version ,version]))

pkgs/racket-doc/scribblings/reference/define-struct.scrbl

@@ -25,6 +25,7 @@
                               (code:line #:property prop-expr val-expr)
                               (code:line #:transparent)
                               (code:line #:prefab)
+                              (code:line #:sealed)
                               (code:line #:authentic)
                               (code:line #:name name-id)
                               (code:line #:extra-name name-id)
@@ -155,9 +156,10 @@ so on. By convention, property names start with @racketidfont{prop:}.}
 The @racket[#:prefab] option obtains a @techlink{prefab} (pre-defined,
 globally shared) structure type, as opposed to creating a new
 structure type. Such a structure type is inherently transparent and
-cannot have a guard or properties, so using @racket[#:prefab] with
+non-sealed, and it cannot have a guard or properties, so using @racket[#:prefab] with
 @racket[#:transparent], @racket[#:inspector], @racket[#:guard],
-@racket[#:property], @racket[#:authentic], or @racket[#:methods] is a syntax error.
+@racket[#:property], @racket[#:sealed], @racket[#:authentic],
+or @racket[#:methods] is a syntax error.
 If a supertype is specified, it must also be a @tech{prefab} structure type.
 
 @examples[#:eval posn-eval
@@ -166,6 +168,11 @@ If a supertype is specified, it must also be a @tech{prefab} structure type.
   (prefab-point? #s(prefab-point 1 2))
 ]
 
+The @racket[#:sealed] option is a shorthand for @racket[#:property
+prop:sealed #t], which prevents the structure type from being
+used as the supertype of another structure type. See
+@racket[prop:sealed] for more information.
+
 The @racket[#:authentic] option is a shorthand for @racket[#:property
 prop:authentic #t], which prevents instances of the structure type
 from being impersonated (see @racket[impersonate-struct]), chaperoned
@@ -299,7 +306,8 @@ cp
 
 For serialization, see @racket[define-serializable-struct].
 
-@history[#:changed "6.9.0.4" @elem{Added @racket[#:authentic].}]}
+@history[#:changed "6.9.0.4" @elem{Added @racket[#:authentic].}
+         #:changed "8.0.0.7" @elem{Added @racket[#:sealed].}]}
 
 
 @defform[(struct-field-index field-id)]{

pkgs/racket-doc/scribblings/reference/struct-inspectors.scrbl

@@ -129,6 +129,23 @@ Returns eight values that provide information about the structure type
 If the type for @racket[struct-type] is not controlled by the current inspector,
 the @exnraise[exn:fail:contract].}
 
+
+@defproc[(struct-type-sealed? [struct-type struct-type?]) boolean?]{
+
+Reports whether @racket[struct-type] has the @racket[prop:sealed]
+structure type property.
+
+@history[#:added "8.0.0.7"]}
+
+
+@defproc[(struct-type-authentic? [struct-type struct-type?]) boolean?]{
+
+Reports whether @racket[struct-type] has the @racket[prop:authentic]
+structure type property.
+
+@history[#:added "8.0.0.7"]}
+
+
 @defproc[(struct-type-make-constructor [struct-type struct-type?]
                                        [constructor-name (or/c symbol? #f) #f])
          struct-constructor-procedure?]{

pkgs/racket-doc/scribblings/reference/struct.scrbl

@@ -275,6 +275,22 @@ structure type if @racket[field-name] is a symbol.
 For examples, see @racket[make-struct-type].}
 
 
+@defthing[prop:sealed struct-type-property?]{
+
+A @tech{structure type property} that declares a structure type as
+@deftech{sealed}. The value associated with the property is ignored;
+the presence of the property itself makes the structure type
+sealed.
+
+A @tech{sealed} structure type cannot be used as the supertype of
+another structure type. Declaring a structure type as @tech{sealed} is
+typically just a performance hint, since checking for an instance of a
+sealed structure type can be slightly faster than checking for an
+instance of a structure type that might have subtypes.
+
+@history[#:added "8.0.0.7"]}
+
+
 @;------------------------------------------------------------------------
 @section[#:tag "structprops"]{Structure Type Properties}
 

pkgs/racket-test-core/tests/racket/struct.rktl

@@ -497,6 +497,8 @@
 (syntax-test #'(define-struct a (b c) #:prefab #:property 1 10))
 (syntax-test #'(define-struct a (b c) #:guard 10 #:prefab))
 (syntax-test #'(define-struct a (b c) #:property 1 10 #:prefab))
+(syntax-test #'(define-struct a (b c) #:sealed #:prefab))
+(syntax-test #'(define-struct a (b c) #:prefab #:sealed))
 
 (define-struct base0 ())
 (define-struct base1 (a))
@@ -842,6 +844,47 @@
 
 (err/rt-test (make-struct-type 'bad struct:date 2 0 #f null 'prefab))
 
+;; ------------------------------------------------------------
+;; Sealed
+
+(err/rt-test (let ()
+               (struct x () #:sealed)
+               (struct y x ())
+               (y))
+             exn:fail:contract?
+             "make-struct-type: cannot make a subtype of a sealed type")
+
+(err/rt-test (let ()
+               (struct x () #:sealed)
+               (struct y x () #:sealed)
+               (y))
+             exn:fail:contract?
+             "make-struct-type: cannot make a subtype of a sealed type")
+
+(err/rt-test (let ()
+               (define-values (prop:s s? s-ref)
+                 (make-struct-type-property 's #f (list (cons prop:sealed (lambda (x) #t)))))
+               (struct x () #:property prop:s #t)
+               (struct y x ())
+               (y))
+             exn:fail:contract?
+             "make-struct-type: cannot make a subtype of a sealed type")
+
+(test '(#f #t) cdr (let ()
+                     (struct x ())
+                     (struct y x () #:sealed)
+                     (list (y)
+                           (struct-type-sealed? struct:x)
+                           (struct-type-sealed? struct:y))))
+
+(err/rt-test (let ()
+               (struct x ())
+               (struct y x () #:sealed)
+               (struct z y ())
+               (y))
+             exn:fail:contract?
+             "make-struct-type: cannot make a subtype of a sealed type")
+
 ;; ------------------------------------------------------------
 ;; Misc. built-in structures
 
@@ -1325,6 +1368,7 @@
 (let ()
   (struct posn (x y) #:authentic)
   (test 1 posn-x (posn 1 2))
+  (test #t struct-type-authentic? struct:posn)
   (err/rt-test (chaperone-struct (posn 1 2) posn-x (lambda (p x) x)))
 
   ;; Subtype must be consistent:
@@ -1334,6 +1378,7 @@
 
 (let ()
   (struct posn (x y))
+  (test #f struct-type-authentic? struct:posn)
 
   ;; Subtype must be consistent:
   (err/rt-test (let ()
@@ -1566,6 +1611,30 @@
 
 ;; ----------------------------------------
 
+(err/rt-test
+ (let ()
+   (struct x ())
+   (define unknown struct:x)
+   (set! unknown unknown)
+
+   (define-values (struct:y y y? y-z)
+     (let-values ([(struct:_1 make-_2 ?_3 -ref_4 -set!_5)
+                   (let-values ()
+                     (let-values ()
+                       (make-struct-type 'y unknown 1 0 #f
+                                         (list)
+                                         'prefab ; (current-inspector)
+                                         #f '() #f 'y)))])
+       (values
+        struct:_1
+        make-_2
+        ?_3
+        (make-struct-field-accessor -ref_4 0 'z))))
+
+   'done)
+ exn:fail:contract?
+ "generative supertype disallowed for non-generative structure type")
+
 (err/rt-test
  (let ()
    ;; Should be arity error (as opposed to a crash)

racket/collects/racket/private/define-struct.rkt

@@ -269,6 +269,7 @@
                            (#:name . #f)
                            (#:only-name? . #f)
                            (#:authentic . #f)
+                           (#:sealed . #f)
                            (#:omit-define-values . #f)
                            (#:omit-define-syntaxes . #f))]
                  [nongen? #f])
@@ -354,6 +355,14 @@
           (loop (cdr p)
                 (extend-config config '#:authentic #'#t)
                 nongen?)]
+         [(eq? '#:sealed (syntax-e (car p)))
+          (when nongen?
+            (bad "cannot use" (car p) " for prefab structure type"))
+          (when (lookup config '#:sealed)
+            (bad "multiple" "#:sealed" "s" (car p)))
+          (loop (cdr p)
+                (extend-config config '#:sealed #'#t)
+                nongen?)]
          [(or (eq? '#:constructor-name (syntax-e (car p)))
               (eq? '#:extra-constructor-name (syntax-e (car p))))
           (check-exprs 1 p "identifier")
@@ -390,6 +399,8 @@
             (bad "multiple" insp-keys "s" (car p)))
           (when (pair? (lookup config '#:props))
             (bad "cannot use" (car p) " for a structure type with properties"))
+          (when (lookup config '#:sealed)
+            (bad "cannot use" (car p) " for a sealed structure type"))
           (when (lookup config '#:guard)
             (bad "cannot use" (car p) " for a structure type with a guard"))
           (loop (cdr p)
@@ -488,11 +499,16 @@
                                 (values (lookup config '#:inspector)
                                         (lookup config '#:super)
                                         (let ([l (lookup config '#:props)]
-                                              [a (lookup config '#:authentic)])
+                                              [a? (lookup config '#:authentic)]
-                                          (if a
+                                              [s? (lookup config '#:sealed)])
+                                          (let ([l (if a?
                                                        (cons (cons #'prop:authentic #'#t)
                                                              l)
-                                              l))
+                                                       l)])
+                                            (if s?
+                                                (cons (cons #'prop:sealed #'#t)
+                                                      l)
+                                                l)))
                                         (lookup config '#:auto-value)
                                         (lookup config '#:guard)
                                         (lookup config '#:constructor-name)

racket/src/ChezScheme/csug/objects.stex

@@ -4402,7 +4402,7 @@ count and mutability mask in place of a vector of field descriptions,
 which results in a record type with anonymous fields. The \var{fields}
 argument must be a non-negative fixnum for the field count, and it is
 added to any fields present in \var{parent} to determine the record
-type's total numnber of fields. The \var{mutability} argument must be
+type's total number of fields. The \var{mutability} argument must be
 an exact non-negative integer that is treated as a bit array; a
 \scheme{1} bit indicates the the corresponding field among
 \var{fields} is mutable.

racket/src/ChezScheme/makefiles/Mf-install.in

@@ -62,7 +62,7 @@ InstallLZ4Target=
 #                 no changes should be needed below this point                #
 ###############################################################################
 
-Version=csv9.5.5.3
+Version=csv9.5.5.4
 Include=boot/$m
 PetiteBoot=boot/$m/petite.boot
 SchemeBoot=boot/$m/scheme.boot

racket/src/ChezScheme/s/cmacros.ss

@@ -357,7 +357,7 @@
 ;; ---------------------------------------------------------------------
 ;; Version and machine types:
 
-(define-constant scheme-version #x09050503)
+(define-constant scheme-version #x09050504)
 
 (define-syntax define-machine-types
   (lambda (x)
@@ -1640,6 +1640,7 @@
 (define-constant rtd-generative #b0001)
 (define-constant rtd-opaque     #b0010)
 (define-constant rtd-sealed     #b0100)
+(define-constant rtd-act-sealed #b1000)
 
 (define-constant ancestry-parent-offset 2)
 (define-constant minimum-ancestry-vector-length 2)

racket/src/ChezScheme/s/cpnanopass.ss

@@ -11123,6 +11123,8 @@
             [(e) (go e (constant rtd-opaque))])
           (define-inline 3 record-type-sealed?
             [(e) (go e (constant rtd-sealed))])
+          (define-inline 3 $record-type-act-sealed?
+            [(e) (go e (fxior (constant rtd-sealed) (constant rtd-act-sealed)))])
           (define-inline 3 record-type-generative?
             [(e) (go e (constant rtd-generative))]))
         (let ()

racket/src/ChezScheme/s/primdata.ss

@@ -2319,6 +2319,8 @@
   ($record-oops [sig [(maybe-who sub-ptr rtd) -> (bottom)]] [flags abort-op])
   ($record-ref [sig [(ptr sub-index) -> (ptr)]] [flags single-valued discard cp03])
   ($record-set! [sig [(ptr sub-index ptr) -> (void)]] [flags true cptypes2])
+  ($record-type-act-sealed! [sig [(ptr) -> (void)]] [flags single-valued true])
+  ($record-type-act-sealed? [sig [(ptr) -> (boolean)]] [flags single-valued])
   ($record-type-descriptor [flags single-valued pure mifoldable discard true])
   ($record-type-field-offsets [flags single-valued pure mifoldable discard true])
   ($record-type-field-count [sig [(ptr) -> (fixnum)]] [flags single-valued pure mifoldable discard true])

racket/src/ChezScheme/s/record.ss

@@ -555,8 +555,8 @@
     (define ($mrt who base-rtd name parent uid flags fields mutability-mask extras)
       (include "layout.ss")
       (when parent
-        (when (record-type-sealed? parent)
+        (when ($record-type-act-sealed? parent)
-          ($oops who "cannot extend sealed record type ~s" parent))
+          ($oops who "cannot extend sealed record type ~s as ~s" parent name))
         (if (fixnum? fields)
             (unless (fixnum? (rtd-flds parent))
               ($oops who "cannot make anonymous-field record type ~s from named-field parent record type ~s" name parent))
@@ -901,6 +901,20 @@
         ($oops 'record-type-sealed? "~s is not a record type descriptor" rtd))
       (#3%record-type-sealed? rtd)))
 
+  (set-who! $record-type-act-sealed!
+    (lambda (rtd)
+      (unless (record-type-descriptor? rtd)
+        ($oops who "~s is not a record type descriptor" rtd))
+      (unless ($record-type-act-sealed? rtd)
+        ($object-set! 'scheme-object rtd (constant record-type-flags-disp)
+                      (fxior (rtd-flags rtd) (constant rtd-act-sealed))))))
+
+  (set-who! $record-type-act-sealed?
+    (lambda (rtd)
+      (unless (record-type-descriptor? rtd)
+        ($oops who "~s is not a record type descriptor" rtd))
+      (#3%$record-type-act-sealed? rtd)))
+
   (set! record-type-generative?
     (lambda (rtd)
       (unless (record-type-descriptor? rtd)

racket/src/bc/src/schminc.h

@@ -15,7 +15,7 @@
 
 #define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 1485
+#define EXPECTED_PRIM_COUNT 1488
 
 #ifdef MZSCHEME_SOMETHING_OMITTED
 # undef USE_COMPILED_STARTUP

racket/src/bc/src/schpriv.h

@@ -700,6 +700,7 @@ extern Scheme_Object *scheme_app_mark_impersonator_property;
 extern Scheme_Object *scheme_no_arity_property;
 
 extern Scheme_Object *scheme_authentic_property;
+extern Scheme_Object *scheme_sealed_property;
 
 extern Scheme_Object *scheme_chaperone_undefined_property;
 
@@ -1095,8 +1096,9 @@ typedef struct Scheme_Struct_Type {
   mzshort num_slots;   /* initialized + auto + parent-initialized + parent-auto */
   mzshort num_islots; /* initialized + parent-initialized */
   mzshort name_pos;
-  char authentic; /* 1 => chaperones/impersonators disallowed */
+  int more_flags; /* STRUCT_TYPE_FLAG_AUTHENTIC => chaperones/impersonators disallowed
-  char more_flags; /* STRUCT_TYPE_FLAG_NONFAIL_CONSTRUCTOR => constructor never fails
+                     STRUCT_TYPE_FLAG_SEALED => subtypes disallowed
+                     STRUCT_TYPE_FLAG_NONFAIL_CONSTRUCTOR => constructor never fails
                      STRUCT_TYPE_FLAG_SYSTEM_OPAQUE => #f for `object-name`, for example */
 
   Scheme_Object *name;
@@ -1131,6 +1133,8 @@ typedef struct Scheme_Struct_Type {
 /* for `more_flags` field */
 #define STRUCT_TYPE_FLAG_NONFAIL_CONSTRUCTOR 0x1
 #define STRUCT_TYPE_FLAG_SYSTEM_OPAQUE       0x2
+#define STRUCT_TYPE_FLAG_AUTHENTIC           0x4
+#define STRUCT_TYPE_FLAG_SEALED              0x8
 
 typedef struct Scheme_Structure
 {
@@ -3108,6 +3112,7 @@ typedef struct {
   int normal_ops;  /* are selectors and predicates in the usual order? */
   int indexed_ops; /* do selectors have the index built in (as opposed to taking an index argument)? */
   int authentic; /* conservatively 0 is ok */
+  int sealed; /* conservatively 0 is ok */
   int nonfail_constructor;
   int prefab;
   int num_gets, num_sets;
@@ -3144,7 +3149,8 @@ Scheme_Object *scheme_make_struct_proc_shape(intptr_t k, Scheme_Object *identity
 #define STRUCT_PROC_SHAPE_GETTER  3
 #define STRUCT_PROC_SHAPE_SETTER  4
 #define STRUCT_PROC_SHAPE_OTHER   5
-#define STRUCT_PROC_SHAPE_MASK    0xF
+#define STRUCT_PROC_SHAPE_MASK    0x7
+#define STRUCT_PROC_SHAPE_SEALED  0x8
 #define STRUCT_PROC_SHAPE_AUTHENTIC       0x10
 #define STRUCT_PROC_SHAPE_NONFAIL_CONSTR  0x20
 #define STRUCT_PROC_SHAPE_PREFAB  0x40

racket/src/bc/src/startup.inc

@@ -5943,6 +5943,7 @@ static const char *startup_source =
 " 0"
 " #f"
 "(list"
+"(cons prop:sealed #t)"
 "(cons prop:authentic #t)"
 "(cons"
 " prop:reach-scopes"
@@ -8910,6 +8911,7 @@ static const char *startup_source =
 " 0"
 " #f"
 "(list"
+"(cons prop:sealed #t)"
 "(cons prop:authentic #t)"
 "(cons"
 " prop:scope-with-bindings"
@@ -9113,6 +9115,7 @@ static const char *startup_source =
 " 0"
 " #f"
 "(list"
+"(cons prop:sealed #t)"
 "(cons prop:authentic #t)"
 "(cons"
 " prop:reach-scopes"
@@ -9976,6 +9979,7 @@ static const char *startup_source =
 " 0"
 " #f"
 "(list"
+"(cons prop:sealed #t)"
 "(cons prop:authentic #t)"
 "(cons prop:propagation-set-tamper(lambda(p_0 v_0)(propagation-set-tamper p_0 v_0)))"
 "(cons prop:propagation-tamper(lambda(p_0)(propagation-tamper p_0)))"
@@ -20887,13 +20891,14 @@ static const char *startup_source =
 " record-accessor"
 " record-mutator"
 " record-predicate"
-" struct-type-install-properties!"
+" make-struct-type-install-properties"
 " #%struct-constructor"
 " #%struct-predicate"
 " #%struct-field-accessor"
 " #%struct-field-mutator"
 " #%nongenerative-uid"
 " unsafe-struct?"
+" unsafe-sealed-struct?"
 " unsafe-struct"
 " raise-binding-result-arity-error"
 " raise-definition-result-arity-error"

racket/src/bc/src/struct.c

@@ -28,6 +28,7 @@ READ_ONLY Scheme_Object *scheme_app_mark_impersonator_property;
 READ_ONLY Scheme_Object *scheme_object_name_property;
 READ_ONLY Scheme_Object *scheme_struct_to_vector_proc;
 READ_ONLY Scheme_Object *scheme_authentic_property;
+READ_ONLY Scheme_Object *scheme_sealed_property;
 READ_ONLY Scheme_Object *scheme_unsafe_poller_proc;
 
 READ_ONLY static Scheme_Object *location_struct;
@@ -115,6 +116,8 @@ static Scheme_Object *struct_info(int argc, Scheme_Object *argv[]);
 static Scheme_Object *struct_type_info(int argc, Scheme_Object *argv[]);
 static Scheme_Object *struct_type_pred(int argc, Scheme_Object *argv[]);
 static Scheme_Object *struct_type_constr(int argc, Scheme_Object *argv[]);
+static Scheme_Object *struct_type_sealed_p(int argc, Scheme_Object *argv[]);
+static Scheme_Object *struct_type_authentic_p(int argc, Scheme_Object *argv[]);
 static Scheme_Object *struct_to_vector(int argc, Scheme_Object *argv[]);
 static Scheme_Object *prefab_struct_key(int argc, Scheme_Object *argv[]);
 static Scheme_Object *make_prefab_struct(int argc, Scheme_Object *argv[]);
@@ -445,6 +448,12 @@ scheme_init_struct (Scheme_Startup_Env *env)
     scheme_addto_prim_instance("prop:authentic", scheme_authentic_property, env);
   }
 
+  {
+    REGISTER_SO(scheme_sealed_property);
+    scheme_sealed_property = scheme_make_struct_type_property(scheme_intern_symbol("sealed"));
+    scheme_addto_prim_instance("prop:sealed", scheme_sealed_property, env);
+  }
+
   REGISTER_SO(scheme_recur_symbol);
   REGISTER_SO(scheme_display_symbol);
   REGISTER_SO(scheme_write_special_symbol);
@@ -577,6 +586,16 @@ scheme_init_struct (Scheme_Startup_Env *env)
 						      "struct-type-make-constructor",
 						      1, 2),
 			     env);
+  scheme_addto_prim_instance("struct-type-sealed?",
+			     scheme_make_prim_w_arity(struct_type_sealed_p,
+						      "struct-type-sealed?",
+						      1, 1),
+			     env);
+  scheme_addto_prim_instance("struct-type-authentic?",
+			     scheme_make_prim_w_arity(struct_type_authentic_p,
+						      "struct-type-authentic?",
+						      1, 1),
+			     env);
 
   REGISTER_SO(scheme_struct_to_vector_proc);
   scheme_struct_to_vector_proc = scheme_make_noncm_prim(struct_to_vector,
@@ -2962,6 +2981,24 @@ static Scheme_Object *struct_type_info(int argc, Scheme_Object *argv[])
   return scheme_values(mzNUM_ST_INFO, a);
 }
 
+static Scheme_Object *struct_type_sealed_p(int argc, Scheme_Object *argv[]) {
+  if (!SCHEME_STRUCT_TYPEP(argv[0]))
+    scheme_wrong_contract("struct-type-sealed?", "struct-type?", 0, argc, argv);
+
+  return ((((Scheme_Struct_Type *)argv[0])->more_flags & STRUCT_TYPE_FLAG_SEALED)
+          ? scheme_true
+          : scheme_false);
+}
+
+static Scheme_Object *struct_type_authentic_p(int argc, Scheme_Object *argv[]) {
+  if (!SCHEME_STRUCT_TYPEP(argv[0]))
+    scheme_wrong_contract("struct-type-authentic?", "struct-type?", 0, argc, argv);
+
+  return ((((Scheme_Struct_Type *)argv[0])->more_flags & STRUCT_TYPE_FLAG_AUTHENTIC)
+          ? scheme_true
+          : scheme_false);
+}
+
 static Scheme_Object *struct_type_pred(int argc, Scheme_Object *argv[])
 {
   Scheme_Struct_Type *stype;
@@ -3428,7 +3465,8 @@ intptr_t scheme_get_or_check_structure_shape(Scheme_Object *e, Scheme_Object *ex
     else
       want_v = ((st->num_slots << STRUCT_PROC_SHAPE_SHIFT)
                 | STRUCT_PROC_SHAPE_STRUCT
-                | ((st->authentic && (!expected || (v & STRUCT_PROC_SHAPE_AUTHENTIC)))
+                | (((st->more_flags & STRUCT_TYPE_FLAG_AUTHENTIC)
+                    && (!expected || (v & STRUCT_PROC_SHAPE_AUTHENTIC)))
                    ? STRUCT_PROC_SHAPE_AUTHENTIC
                    : 0)
                 | (((st->more_flags & STRUCT_TYPE_FLAG_NONFAIL_CONSTRUCTOR)
@@ -3455,7 +3493,8 @@ intptr_t scheme_get_or_check_structure_shape(Scheme_Object *e, Scheme_Object *ex
     } else if (i == SCHEME_PRIM_STRUCT_TYPE_PRED) {
       st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0];
       want_v = (STRUCT_PROC_SHAPE_PRED
-                | ((st->authentic && (!expected || (v & STRUCT_PROC_SHAPE_AUTHENTIC)))
+                | (((st->more_flags & STRUCT_TYPE_FLAG_AUTHENTIC)
+                    && (!expected || (v & STRUCT_PROC_SHAPE_AUTHENTIC)))
                    ? STRUCT_PROC_SHAPE_AUTHENTIC
                    : 0));
     } else if (i == SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER) {
@@ -3471,7 +3510,8 @@ intptr_t scheme_get_or_check_structure_shape(Scheme_Object *e, Scheme_Object *ex
         pos = 0; /* => unknown, since simple struct info can't track it */
       want_v = ((pos << STRUCT_PROC_SHAPE_SHIFT)
                 | STRUCT_PROC_SHAPE_SETTER
-                | ((st->authentic && (!expected || (v & STRUCT_PROC_SHAPE_AUTHENTIC)))
+                | (((st->more_flags & STRUCT_TYPE_FLAG_AUTHENTIC)
+                    && (!expected || (v & STRUCT_PROC_SHAPE_AUTHENTIC)))
                    ? STRUCT_PROC_SHAPE_AUTHENTIC
                    : 0));
     } else if (i == SCHEME_PRIM_STRUCT_TYPE_INDEXED_GETTER) {
@@ -3479,7 +3519,8 @@ intptr_t scheme_get_or_check_structure_shape(Scheme_Object *e, Scheme_Object *ex
       st = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(e)[0];
       want_v = ((pos << STRUCT_PROC_SHAPE_SHIFT) 
                 | STRUCT_PROC_SHAPE_GETTER
-                | ((st->authentic && (!expected || (v & STRUCT_PROC_SHAPE_AUTHENTIC)))
+                | (((st->more_flags & STRUCT_TYPE_FLAG_AUTHENTIC)
+                    && (!expected || (v & STRUCT_PROC_SHAPE_AUTHENTIC)))
                    ? STRUCT_PROC_SHAPE_AUTHENTIC
                    : 0));
     } else if ((i == SCHEME_PRIM_STRUCT_TYPE_INDEXLESS_SETTER)
@@ -4751,7 +4792,6 @@ Scheme_Struct_Type *scheme_make_prefab_struct_type_raw(Scheme_Object *base,
   struct_type->num_slots = num_fields + num_uninit_fields + (parent_type ? parent_type->num_slots : 0);
   struct_type->num_islots = num_fields + (parent_type ? parent_type->num_islots : 0);
   struct_type->name_pos = depth;
-  struct_type->authentic = 0;
   struct_type->more_flags = STRUCT_TYPE_FLAG_NONFAIL_CONSTRUCTOR;
   struct_type->inspector = scheme_false;
   struct_type->uninit_val = uninit_val;
@@ -4946,7 +4986,9 @@ static Scheme_Object *_make_struct_type(Scheme_Object *name,
         if (SAME_OBJ(prop, scheme_chaperone_undefined_property))
           chaperone_undefined = 1;
         if (SAME_OBJ(prop, scheme_authentic_property))
-          struct_type->authentic = 1;
+          struct_type->more_flags |= STRUCT_TYPE_FLAG_AUTHENTIC;
+        if (SAME_OBJ(prop, scheme_sealed_property))
+          struct_type->more_flags |= STRUCT_TYPE_FLAG_SEALED;
 
         propv = guard_property(prop, SCHEME_CDR(a), struct_type);
         
@@ -5008,7 +5050,9 @@ static Scheme_Object *_make_struct_type(Scheme_Object *name,
         if (SAME_OBJ(prop, scheme_chaperone_undefined_property))
           chaperone_undefined = 1;
         if (SAME_OBJ(prop, scheme_authentic_property))
-          struct_type->authentic = 1;
+          struct_type->more_flags |= STRUCT_TYPE_FLAG_AUTHENTIC;
+        if (SAME_OBJ(prop, scheme_sealed_property))
+          struct_type->more_flags |= STRUCT_TYPE_FLAG_SEALED;
 
         propv = guard_property(prop, SCHEME_CDR(a), struct_type);
 
@@ -5062,8 +5106,9 @@ static Scheme_Object *_make_struct_type(Scheme_Object *name,
     }
   }
 
-  if (parent_type && (parent_type->authentic != struct_type->authentic)) {
+  if (parent_type && ((parent_type->more_flags & STRUCT_TYPE_FLAG_AUTHENTIC)
-    if (parent_type->authentic)
+                      != (struct_type->more_flags & STRUCT_TYPE_FLAG_AUTHENTIC))) {
+    if (parent_type->more_flags & STRUCT_TYPE_FLAG_AUTHENTIC)
       scheme_contract_error("make-struct-type",
                             "cannot make a non-authentic subtype of an authentic type",
                             "type name", 1, struct_type->name,
@@ -5402,8 +5447,24 @@ static Scheme_Object *make_struct_type(int argc, Scheme_Object **argv)
                                           uninit_val,
                                           immutable_array);
   } else {
+    Scheme_Object *parent = SCHEME_FALSEP(argv[1]) ? NULL : argv[1];
+    Scheme_Struct_Type *parent_type;
+    
+    if (parent && SCHEME_NP_CHAPERONEP(parent))
+      parent_type = (Scheme_Struct_Type *)SCHEME_CHAPERONE_VAL(parent);
+    else
+      parent_type = (Scheme_Struct_Type *)parent;
+      
+    if (parent_type && (parent_type->more_flags & STRUCT_TYPE_FLAG_SEALED)) {
+      scheme_contract_error("make-struct-type",
+                            "cannot make a subtype of a sealed type",
+                            "type name", 1, argv[0],
+                            "sealed type", 1, parent,
+                            NULL);
+    }
+
     type = (Scheme_Struct_Type *)_make_struct_type(argv[0],
-                                                   SCHEME_FALSEP(argv[1]) ? NULL : argv[1],
+                                                   parent,
                                                    inspector,
                                                    initc, uninitc,
                                                    uninit_val, props,
@@ -6247,7 +6308,7 @@ static Scheme_Object *do_chaperone_struct(const char *name, int is_impersonator,
     return NULL;
   }
 
-  if (SCHEME_STRUCTP(val) && ((Scheme_Structure *)val)->stype->authentic) {
+  if (SCHEME_STRUCTP(val) && ((Scheme_Structure *)val)->stype->more_flags & STRUCT_TYPE_FLAG_AUTHENTIC) {
     scheme_contract_error(name,
                           (is_impersonator
                            ? "cannot impersonate instance of an authentic structure type"

racket/src/cs/compile-file.ss

@@ -2,7 +2,7 @@
 ;; Check to make we're using a build of Chez Scheme
 ;; that has all the features we need.
 (define-values (need-maj need-min need-sub need-dev)
-  (values 9 5 5 1))
+  (values 9 5 5 4))
 
 (unless (guard (x [else #f]) (eval 'scheme-fork-version-number))
   (error 'compile-file

racket/src/cs/primitive/internal.ss

@@ -8,7 +8,7 @@
   [impersonator-val (known-constant)]
   [impersonate-ref (known-constant)]
   [impersonate-set! (known-constant)]
-  [struct-type-install-properties! (known-constant)]
+  [make-struct-type-install-properties (known-constant)]
   [structure-type-lookup-prefab-uid (known-constant)]
   [struct-type-constructor-add-guards (known-constant)]
   [|#%call-with-values| (known-constant)]

racket/src/cs/primitive/kernel.ss

@@ -686,6 +686,7 @@
   [prop:object-name (known-constant)]
   [prop:output-port (known-constant)]
   [prop:procedure (known-struct-type-property/immediate-guard)]
+  [prop:sealed (known-struct-type-property/immediate-guard)]
   [pseudo-random-generator->vector (known-procedure/no-prompt 2)]
   [pseudo-random-generator-vector? (known-procedure/no-prompt 2)]
   [pseudo-random-generator? (known-procedure/pure/folding 2)]
@@ -840,12 +841,14 @@
   [struct-info (known-procedure 2)]
   [struct-mutator-procedure? (known-procedure/pure/folding 2)]
   [struct-predicate-procedure? (known-procedure/pure/folding 2)]
+  [struct-type-authentic? (known-procedure/single-valued 2)]
   [struct-type-info (known-procedure 2)]
   [struct-type-make-constructor (known-procedure/single-valued 6)]
   [struct-type-make-predicate (known-procedure/single-valued 2)]
   [struct-type-property-accessor-procedure? (known-procedure/single-valued 2)]
   [struct-type-property-predicate-procedure? (known-procedure/single-valued 6)]
   [struct-type-property? (known-procedure/no-prompt 2)]
+  [struct-type-sealed? (known-procedure/single-valued 2)]
   [struct-type? (known-procedure/no-prompt 2)]
   [struct:arity-at-least (known-constant)]
   [struct:date (known-constant)]

racket/src/cs/rumble.sls

@@ -218,7 +218,7 @@
           struct-type-property-accessor-procedure?
           struct-type-property-predicate-procedure?
           make-struct-type
-          struct-type-install-properties! ; not exported to Racket
+          make-struct-type-install-properties ; not exported to Racket
           structure-type-lookup-prefab-uid    ; not exported to Racket
           make-struct-field-accessor
           make-struct-field-mutator
@@ -237,6 +237,8 @@
           struct-type?
           procedure-struct-type?
           struct-type-info
+          struct-type-sealed?
+          struct-type-authentic?
           struct-info
           struct-type-make-constructor
           struct-type-make-predicate
@@ -247,6 +249,7 @@
           make-prefab-struct
           prop:authentic
           prop:equal+hash
+          prop:sealed
           inspector?
           inspector-superior?
           impersonate-struct
@@ -697,6 +700,7 @@
           unsafe-struct*-set!
           unsafe-struct*-cas!
           unsafe-struct?        ; not exported to racket
+          unsafe-sealed-struct? ; not exported to racket
           unsafe-struct         ; not exported to racket
 
           unsafe-s16vector-ref

racket/src/cs/rumble/error-rewrite.ss

@@ -59,7 +59,8 @@
                 fxarithmetic-shift-left fxlshift
                 fxsll/wraparound fxlshift/wraparound
                 real->flonum ->fl
-                time-utc->date seconds->date)
+                time-utc->date seconds->date
+                make-record-type-descriptor* make-struct-type)
         (set! rewrites-added? #t)))
     (getprop n 'error-rename n)))
 
@@ -140,6 +141,11 @@
     (let ([ctc (desc->contract (substring str (string-length is-not-a-str) (string-length str)))])
       (format-error-values (string-append "contract violation\n  expected: " ctc "\n  given: ~s")
                            irritants))]
+   [(equal? str "cannot extend sealed record type ~s as ~s")
+    (format-error-values (string-append "cannot make a subtype of a sealed type\n"
+                                        "  type name: ~s\n"
+                                        "  sealed type: ~s")
+                         (reverse irritants))]
    [(eq? who 'time-utc->date)
     (values "integer is out-of-range" null)]
    [else

racket/src/cs/rumble/struct.ss

@@ -183,8 +183,10 @@
 
 ;; ----------------------------------------
 
+;; returns a procedure that takes an rtd and finishes creating/installing it
 (define (check-make-struct-type-arguments who name parent-rtd init-count auto-count
-                                          props insp proc-spec immutables guard constructor-name)
+                                          props insp proc-spec immutables guard constructor-name
+                                          system?)
   (check who symbol? name)
   (check who :or-false struct-type? parent-rtd)
   (check who exact-nonnegative-integer? init-count)
@@ -215,8 +217,63 @@
   (check who :or-false procedure? guard)
   (check who :or-false symbol? constructor-name)
 
+  (cond
+    [(eq? insp 'prefab)
+     (let ([bad
+            (or (and (impersonator? parent-rtd)
+                     "chaperoned supertype disallowed for non-generative structure type")
+                (and parent-rtd
+                     (not (eq? (inspector-ref (strip-impersonator parent-rtd)) 'prefab))
+                     "generative supertype disallowed for non-generative structure type")
+                (and (pair? props)
+                     "properties disallowed for non-generative structure type")
+                (and proc-spec
+                     "procedure specification disallowed for non-generative structure type")
+                (and guard
+                     "guard disallowed for non-generative structure type"))])
+       (when bad
+         (raise-arguments-error who bad
+                                "structure type name" name))
+       ;; everything else to be done for a for prefab must be covered in `prefab-key+count->rtd`
+       (lambda (rtd)
+         (void)))]
+    [else
+     (when parent-rtd
+       (when (#%$record-type-act-sealed? (strip-impersonator parent-rtd))
+         (raise-arguments-error who
+                                "cannot make a subtype of a sealed type"
+                                "type name" name
+                                "sealed type" parent-rtd)))
+
      ;; The rest has to be delayed until we have an rtd:
-  (lambda (rtd parent-rtd* all-immutables)
+     (lambda (rtd)
+       (let* ([parent-rtd* (strip-impersonator parent-rtd)]
+              [parent-props
+               (if parent-rtd*
+                   (eq-hashtable-ref rtd-props parent-rtd* '())
+                   '())]
+              [all-immutables (if (integer? proc-spec)
+                                  (cons proc-spec immutables)
+                                  immutables)])
+         (when (not parent-rtd*)
+           (record-type-equal-procedure rtd default-struct-equal?)
+           (record-type-hash-procedure rtd default-struct-hash))
+         ;; Record properties implemented by this type:
+         (let ([props (let ([props (append (map car props) parent-props)])
+                        (if proc-spec
+                            (cons prop:procedure props)
+                            props))])
+           (add-to-table! rtd-props rtd props))
+         ;; Copy parent properties for this type:
+         (for-each (lambda (prop)
+                     (let loop ([prop prop])
+                       (struct-property-set! prop rtd (struct-property-ref prop parent-rtd* #f))
+                       (for-each (lambda (super)
+                                   (loop (car super)))
+                                 (struct-type-prop-supers prop))))
+                   parent-props)
+
+         ;; Finish checking and install new property values:
          (let ([props-ht
                 ;; Check for duplicates and record property values
                 (let ([get-struct-info
@@ -245,23 +302,6 @@
                                                                         get-struct-info)])
                          (loop props ht))])))])
 
-      (when (eq? insp 'prefab)
-        (let ([bad
-               (or (and (impersonator? parent-rtd)
-                        "chaperoned supertype disallowed for non-generative structure type")
-                   (and parent-rtd
-                        (not (eq? (inspector-ref parent-rtd) 'prefab))
-                        "generative supertype disallowed for non-generative structure type")
-                   (and (pair? props)
-                        "properties disallowed for non-generative structure type")
-                   (and proc-spec
-                        "procedure specification disallowed for non-generative structure type")
-                   (and guard
-                        "guard disallowed for non-generative structure type"))])
-          (when bad
-            (raise-arguments-error who bad
-                                   "structure type name" name))))
-
            (let loop ([ht empty-hasheqv] [imms immutables])
              (cond
                [(null? imms) (void)]
@@ -328,7 +368,13 @@
                                            "guard procedure does not accept correct number of arguments;\n"
                                            " should accept one more than the number of constructor arguments")
                                           "guard procedure" guard
-                                     "expected arity" expected-count))))))))
+                                          "expected arity" expected-count))))))
+         
+         ;; Record inspector
+         (unless (and system? insp)
+           (inspector-set! rtd insp))
+         ;; Register guard
+         (register-guards! rtd parent-rtd guard 'at-start)))]))
 
 (define (check-and-add-property who prop val rtd ht props get-struct-info)
   (let* ([guarded-val
@@ -359,6 +405,11 @@
                                             p
                                             (lambda (v h) (|#%app| p v h)))))
       (struct-property-set! 'secondary-hash rtd (cadddr guarded-val)))
+    (cond
+      [(eq? prop prop:sealed)
+       (#%$record-type-act-sealed! rtd)
+       (values ht props)]
+      [else
        (struct-property-set! prop rtd guarded-val)
        (values (hash-set ht prop check-val)
                (append
@@ -369,7 +420,27 @@
                          (struct-type-prop-supers prop))
                     ;; skip supers, because property is already added
                     null)
-             props))))
+                props))])))
+
+;; variant of `check-make-struct-type-arguments` called by schemified
+(define make-struct-type-install-properties
+  (case-lambda
+   [(name init-count auto-count parent-rtd)
+    (make-struct-type-install-properties name init-count auto-count parent-rtd '() (current-inspector) #f '() #f #f)]
+   [(name init-count auto-count parent-rtd props)
+    (make-struct-type-install-properties name init-count auto-count parent-rtd props (current-inspector) #f '() #f #f)]
+   [(name init-count auto-count parent-rtd props insp)
+    (make-struct-type-install-properties name init-count auto-count parent-rtd props insp #f '() #f #f)]
+   [(name init-count auto-count parent-rtd props insp proc-spec)
+    (make-struct-type-install-properties name init-count auto-count parent-rtd props insp proc-spec '() #f #f)]
+   [(name init-count auto-count parent-rtd props insp proc-spec immutables)
+    (make-struct-type-install-properties name init-count auto-count parent-rtd props insp proc-spec immutables #f #f)]
+   [(name init-count auto-count parent-rtd props insp proc-spec immutables guard)
+    (make-struct-type-install-properties name init-count auto-count parent-rtd props insp proc-spec immutables guard #f)]
+   [(name init-count auto-count parent-rtd props insp proc-spec immutables guard constructor-name)
+    ;; returns a finishing procedure
+    (check-make-struct-type-arguments 'make-struct-type (if (pair? name) (car name) name) parent-rtd init-count auto-count
+                                      props insp proc-spec immutables guard constructor-name (pair? name))]))
 
 ;; ----------------------------------------
 
@@ -488,9 +559,8 @@
     [(name parent-rtd init-count auto-count auto-val props insp proc-spec immutables guard)
      (make-struct-type name parent-rtd init-count auto-count auto-val props insp proc-spec immutables guard #f)]
     [(name parent-rtd init-count auto-count auto-val props insp proc-spec immutables guard constructor-name)
-     (let* ([install-props!
+     (let* ([finish! (check-make-struct-type-arguments 'make-struct-type name parent-rtd init-count auto-count
-             (check-make-struct-type-arguments 'make-struct-type name parent-rtd init-count auto-count
+                                                       props insp proc-spec immutables guard constructor-name #f)]
-                                               props insp proc-spec immutables guard constructor-name)]
             [prefab-uid (and (eq? insp 'prefab)
                              (structure-type-lookup-prefab-uid name parent-rtd init-count auto-count auto-val immutables))]
             [parent-rtd* (strip-impersonator parent-rtd)]
@@ -499,7 +569,9 @@
                            empty-field-info)]
             [rtd (make-record-type-descriptor* name
                                                parent-rtd*
-                                               prefab-uid #f #f
+                                               prefab-uid
+                                               (#%ormap (lambda (p) (eq? prop:sealed (car p))) props)
+                                               #f
                                                (+ init-count auto-count)
                                                (let ([mask (sub1 (general-arithmetic-shift 1 (+ init-count auto-count)))])
                                                  (if (eq? insp 'prefab)
@@ -527,9 +599,7 @@
        (when (or parent-rtd* auto-field-adder)
          (let ([field-info (make-field-info init*-count auto*-count auto-field-adder)])
            (putprop (record-type-uid rtd) 'field-info field-info)))
-       (struct-type-install-properties! rtd name init-count auto-count parent-rtd
+       (finish! rtd)
-                                        props insp proc-spec immutables guard constructor-name
-                                        install-props!)
        (let ([ctr (struct-type-constructor-add-guards
                    (let ([c (record-constructor rtd)])
                      (procedure-rename
@@ -554,63 +624,6 @@
                  (make-position-based-accessor rtd parent-total*-count (+ init-count auto-count))
                  (make-position-based-mutator rtd parent-total*-count (+ init-count auto-count)))))]))
 
-;; Called both by `make-struct-type` and by a `schemify` transformation:
-(define struct-type-install-properties!
-  (case-lambda
-   [(rtd name init-count auto-count parent-rtd)
-    (struct-type-install-properties! rtd name init-count auto-count parent-rtd '() (current-inspector) #f '() #f #f #f)]
-   [(rtd name init-count auto-count parent-rtd props)
-    (struct-type-install-properties! rtd name init-count auto-count parent-rtd props (current-inspector) #f '() #f #f #f)]
-   [(rtd name init-count auto-count parent-rtd props insp)
-    (struct-type-install-properties! rtd name init-count auto-count parent-rtd props insp #f '() #f #f #f)]
-   [(rtd name init-count auto-count parent-rtd props insp proc-spec)
-    (struct-type-install-properties! rtd name init-count auto-count parent-rtd props insp proc-spec '() #f #f #f)]
-   [(rtd name init-count auto-count parent-rtd props insp proc-spec immutables)
-    (struct-type-install-properties! rtd name init-count auto-count parent-rtd props insp proc-spec immutables #f #f #f)]
-   [(rtd name init-count auto-count parent-rtd props insp proc-spec immutables guard)
-    (struct-type-install-properties! rtd name init-count auto-count parent-rtd props insp proc-spec immutables guard #f #f)]
-   [(rtd name init-count auto-count parent-rtd props insp proc-spec immutables guard constructor-name)
-    (struct-type-install-properties! rtd name init-count auto-count parent-rtd props insp proc-spec immutables guard constructor-name #f)]
-   [(rtd name init-count auto-count parent-rtd props insp proc-spec immutables guard constructor-name install-props!)
-    (let ([install-props!
-           (or install-props!
-               (check-make-struct-type-arguments 'make-struct-type (if (pair? name) (car name) name) parent-rtd init-count auto-count
-                                                 props insp proc-spec immutables guard constructor-name))])
-      (unless (eq? insp 'prefab) ; everything for prefab must be covered in `prefab-key+count->rtd`
-        (let* ([parent-rtd* (strip-impersonator parent-rtd)]
-               [parent-props
-                (if parent-rtd*
-                    (eq-hashtable-ref rtd-props parent-rtd* '())
-                    '())]
-               [all-immutables (if (integer? proc-spec)
-                                   (cons proc-spec immutables)
-                                   immutables)])
-          (when (not parent-rtd*)
-            (record-type-equal-procedure rtd default-struct-equal?)
-            (record-type-hash-procedure rtd default-struct-hash))
-          ;; Record properties implemented by this type:
-          (let ([props (let ([props (append (map car props) parent-props)])
-                         (if proc-spec
-                             (cons prop:procedure props)
-                             props))])
-            (add-to-table! rtd-props rtd props))
-          ;; Copy parent properties for this type:
-          (for-each (lambda (prop)
-                      (let loop ([prop prop])
-                        (struct-property-set! prop rtd (struct-property-ref prop parent-rtd* #f))
-                        (for-each (lambda (super)
-                                    (loop (car super)))
-                                  (struct-type-prop-supers prop))))
-                    parent-props)
-          ;; Finish checking and install new property values:
-          (install-props! rtd parent-rtd* all-immutables)
-          ;; Record inspector
-          (unless (and (pair? name) ; pair implies a system structure type
-                       insp)
-            (inspector-set! rtd insp))
-          ;; Register guard
-          (register-guards! rtd parent-rtd guard 'at-start))))]))
-
 ;; Field count (init + auto) not including parent fields
 (define (record-type-field-count rtd)
   (fx- (#%$record-type-field-count rtd)
@@ -878,6 +891,14 @@
                            "current inspector cannot extract info for structure type"
                            "structure type" rtd)))
 
+(define/who (struct-type-sealed? rtd)
+  (check who struct-type? rtd)
+  (#%$record-type-act-sealed? (strip-impersonator rtd)))
+
+(define/who (struct-type-authentic? rtd)
+  (check who struct-type? rtd)
+  (struct-property-ref prop:authentic (strip-impersonator rtd) #f))
+
 (define/who struct-type-make-constructor
   (case-lambda
    [(rtd) (struct-type-make-constructor rtd #f)]
@@ -1085,6 +1106,8 @@
   (#%$record-set! s i v))
 (define (unsafe-struct? v r)
   (#3%record? v r))
+(define (unsafe-sealed-struct? v r)
+  (#3%$sealed-record? v r))
 
 ;; internal use only, so doesn't need to have 'unsafe-struct as it's name, etc.:
 (define unsafe-struct #%$record)
@@ -1133,6 +1156,12 @@
 (define-values (prop:authentic-override authentic-override? authentic-override-ref)
   (make-struct-type-property 'authentic-override (lambda (val info) #t)))
 
+;; A struct with prop:sealed is normally also `record-type-sealed?`, but
+;; the schemify transformation might pessimistically generate a non-sealed
+;; record type
+(define-values (prop:sealed sealed? sealed-ref)
+  (make-struct-type-property 'sealed (lambda (val info) #t)))
+
 (define (struct-type-immediate-transparent? rtd)
   (let ([insp (inspector-ref rtd)])
     (and (not (eq? insp none))

racket/src/cs/schemified/regexp.scm

@@ -865,18 +865,8 @@
 (define rx:line-end 'line-end)
 (define rx:word-boundary 'word-boundary)
 (define rx:not-word-boundary 'not-word-boundary)
-(define struct:rx:alts
+(define finish39
-  (make-record-type-descriptor*
+  (make-struct-type-install-properties
-   'rx:alts
-   #f
-   (|#%nongenerative-uid| rx:alts)
-   #f
-   #f
-   2
-   0))
-(define effect_1936
-  (struct-type-install-properties!
-   struct:rx:alts
    '(rx:alts)
    2
    0
@@ -887,6 +877,16 @@
    '(0 1)
    #f
    'rx:alts))
+(define struct:rx:alts
+  (make-record-type-descriptor*
+   'rx:alts
+   #f
+   (|#%nongenerative-uid| rx:alts)
+   #f
+   #f
+   2
+   0))
+(define effect_2414 (finish39 struct:rx:alts))
 (define rx:alts1.1
   (|#%name|
    rx:alts
@@ -921,18 +921,8 @@
        (rx:alts-rx_2917 s)
        ($value
         (impersonate-ref rx:alts-rx_2917 struct:rx:alts 1 s 'rx:alts 'rx2))))))
-(define struct:rx:sequence
+(define finish44
-  (make-record-type-descriptor*
+  (make-struct-type-install-properties
-   'rx:sequence
-   #f
-   (|#%nongenerative-uid| rx:sequence)
-   #f
-   #f
-   2
-   0))
-(define effect_2662
-  (struct-type-install-properties!
-   struct:rx:sequence
    '(rx:sequence)
    2
    0
@@ -943,6 +933,16 @@
    '(0 1)
    #f
    'rx:sequence))
+(define struct:rx:sequence
+  (make-record-type-descriptor*
+   'rx:sequence
+   #f
+   (|#%nongenerative-uid| rx:sequence)
+   #f
+   #f
+   2
+   0))
+(define effect_2459 (finish44 struct:rx:sequence))
 (define rx:sequence2.1
   (|#%name|
    rx:sequence
@@ -992,18 +992,8 @@
          s
          'rx:sequence
          'needs-backtrack?))))))
-(define struct:rx:group
+(define finish49
-  (make-record-type-descriptor*
+  (make-struct-type-install-properties
-   'rx:group
-   #f
-   (|#%nongenerative-uid| rx:group)
-   #f
-   #f
-   2
-   0))
-(define effect_3021
-  (struct-type-install-properties!
-   struct:rx:group
    '(rx:group)
    2
    0
@@ -1014,6 +1004,16 @@
    '(0 1)
    #f
    'rx:group))
+(define struct:rx:group
+  (make-record-type-descriptor*
+   'rx:group
+   #f
+   (|#%nongenerative-uid| rx:group)
+   #f
+   #f
+   2
+   0))
+(define effect_1819 (finish49 struct:rx:group))
 (define rx:group3.1
   (|#%name|
    rx:group
@@ -1060,18 +1060,8 @@
          s
          'rx:group
          'number))))))
-(define struct:rx:repeat
+(define finish54
-  (make-record-type-descriptor*
+  (make-struct-type-install-properties
-   'rx:repeat
-   #f
-   (|#%nongenerative-uid| rx:repeat)
-   #f
-   #f
-   4
-   0))
-(define effect_2413
-  (struct-type-install-properties!
-   struct:rx:repeat
    '(rx:repeat)
    4
    0
@@ -1082,6 +1072,16 @@
    '(0 1 2 3)
    #f
    'rx:repeat))
+(define struct:rx:repeat
+  (make-record-type-descriptor*
+   'rx:repeat
+   #f
+   (|#%nongenerative-uid| rx:repeat)
+   #f
+   #f
+   4
+   0))
+(define effect_2312 (finish54 struct:rx:repeat))
 (define rx:repeat4.1
   (|#%name|
    rx:repeat
@@ -1161,18 +1161,8 @@
          s
          'rx:repeat
          'non-greedy?))))))
-(define struct:rx:maybe
+(define finish61
-  (make-record-type-descriptor*
+  (make-struct-type-install-properties
-   'rx:maybe
-   #f
-   (|#%nongenerative-uid| rx:maybe)
-   #f
-   #f
-   2
-   0))
-(define effect_1615
-  (struct-type-install-properties!
-   struct:rx:maybe
    '(rx:maybe)
    2
    0
@@ -1183,6 +1173,16 @@
    '(0 1)
    #f
    'rx:maybe))
+(define struct:rx:maybe
+  (make-record-type-descriptor*
+   'rx:maybe
+   #f
+   (|#%nongenerative-uid| rx:maybe)
+   #f
+   #f
+   2
+   0))
+(define effect_2202 (finish61 struct:rx:maybe))
 (define rx:maybe5.1
   (|#%name|
    rx:maybe
@@ -1229,18 +1229,8 @@
          s
          'rx:maybe
          'non-greedy?))))))
-(define struct:rx:conditional
+(define finish66
-  (make-record-type-descriptor*
+  (make-struct-type-install-properties
-   'rx:conditional
-   #f
-   (|#%nongenerative-uid| rx:conditional)
-   #f
-   #f
-   6
-   0))
-(define effect_2714
-  (struct-type-install-properties!
-   struct:rx:conditional
    '(rx:conditional)
    6
    0
@@ -1251,6 +1241,16 @@
    '(0 1 2 3 4 5)
    #f
    'rx:conditional))
+(define struct:rx:conditional
+  (make-record-type-descriptor*
+   'rx:conditional
+   #f
+   (|#%nongenerative-uid| rx:conditional)
+   #f
+   #f
+   6
+   0))
+(define effect_2905 (finish66 struct:rx:conditional))
 (define rx:conditional6.1
   (|#%name|
    rx:conditional
@@ -1366,18 +1366,8 @@
          s
          'rx:conditional
          'needs-backtrack?))))))
-(define struct:rx:lookahead
+(define finish75
-  (make-record-type-descriptor*
+  (make-struct-type-install-properties
-   'rx:lookahead
-   #f
-   (|#%nongenerative-uid| rx:lookahead)
-   #f
-   #f
-   4
-   0))
-(define effect_2193
-  (struct-type-install-properties!
-   struct:rx:lookahead
    '(rx:lookahead)
    4
    0
@@ -1388,6 +1378,16 @@
    '(0 1 2 3)
    #f
    'rx:lookahead))
+(define struct:rx:lookahead
+  (make-record-type-descriptor*
+   'rx:lookahead
+   #f
+   (|#%nongenerative-uid| rx:lookahead)
+   #f
+   #f
+   4
+   0))
+(define effect_2486 (finish75 struct:rx:lookahead))
 (define rx:lookahead7.1
   (|#%name|
    rx:lookahead
@@ -1469,18 +1469,8 @@
          s
          'rx:lookahead
          'num-n))))))
-(define struct:rx:lookbehind
+(define finish82
-  (make-record-type-descriptor*
+  (make-struct-type-install-properties
-   'rx:lookbehind
-   #f
-   (|#%nongenerative-uid| rx:lookbehind)
-   #f
-   #f
-   6
-   12))
-(define effect_2578
-  (struct-type-install-properties!
-   struct:rx:lookbehind
    '(rx:lookbehind)
    6
    0
@@ -1491,6 +1481,16 @@
    '(0 1 4 5)
    #f
    'rx:lookbehind))
+(define struct:rx:lookbehind
+  (make-record-type-descriptor*
+   'rx:lookbehind
+   #f
+   (|#%nongenerative-uid| rx:lookbehind)
+   #f
+   #f
+   6
+   12))
+(define effect_2468 (finish82 struct:rx:lookbehind))
 (define rx:lookbehind8.1
   (|#%name|
    rx:lookbehind
@@ -1640,18 +1640,8 @@
          v
          'rx:lookbehind
          'lb-max))))))
-(define struct:rx:cut
+(define finish93
-  (make-record-type-descriptor*
+  (make-struct-type-install-properties
-   'rx:cut
-   #f
-   (|#%nongenerative-uid| rx:cut)
-   #f
-   #f
-   4
-   0))
-(define effect_2428
-  (struct-type-install-properties!
-   struct:rx:cut
    '(rx:cut)
    4
    0
@@ -1662,6 +1652,16 @@
    '(0 1 2 3)
    #f
    'rx:cut))
+(define struct:rx:cut
+  (make-record-type-descriptor*
+   'rx:cut
+   #f
+   (|#%nongenerative-uid| rx:cut)
+   #f
+   #f
+   4
+   0))
+(define effect_2158 (finish93 struct:rx:cut))
 (define rx:cut9.1
   (|#%name|
    rx:cut
@@ -1733,18 +1733,8 @@
          s
          'rx:cut
          'needs-backtrack?))))))
-(define struct:rx:reference
+(define finish100
-  (make-record-type-descriptor*
+  (make-struct-type-install-properties
-   'rx:reference
-   #f
-   (|#%nongenerative-uid| rx:reference)
-   #f
-   #f
-   2
-   0))
-(define effect_2572
-  (struct-type-install-properties!
-   struct:rx:reference
    '(rx:reference)
    2
    0
@@ -1755,6 +1745,16 @@
    '(0 1)
    #f
    'rx:reference))
+(define struct:rx:reference
+  (make-record-type-descriptor*
+   'rx:reference
+   #f
+   (|#%nongenerative-uid| rx:reference)
+   #f
+   #f
+   2
+   0))
+(define effect_2306 (finish100 struct:rx:reference))
 (define rx:reference10.1
   (|#%name|
    rx:reference
@@ -1806,18 +1806,8 @@
          s
          'rx:reference
          'case-sensitive?))))))
-(define struct:rx:range
+(define finish105
-  (make-record-type-descriptor*
+  (make-struct-type-install-properties
-   'rx:range
-   #f
-   (|#%nongenerative-uid| rx:range)
-   #f
-   #f
-   1
-   0))
-(define effect_2430
-  (struct-type-install-properties!
-   struct:rx:range
    '(rx:range)
    1
    0
@@ -1828,6 +1818,16 @@
    '(0)
    #f
    'rx:range))
+(define struct:rx:range
+  (make-record-type-descriptor*
+   'rx:range
+   #f
+   (|#%nongenerative-uid| rx:range)
+   #f
+   #f
+   1
+   0))
+(define effect_2071 (finish105 struct:rx:range))
 (define rx:range11.1
   (|#%name|
    rx:range
@@ -1858,18 +1858,8 @@
          s
          'rx:range
          'range))))))
-(define struct:rx:unicode-categories
+(define finish109
-  (make-record-type-descriptor*
+  (make-struct-type-install-properties
-   'rx:unicode-categories
-   #f
-   (|#%nongenerative-uid| rx:unicode-categories)
-   #f
-   #f
-   2
-   0))
-(define effect_2489
-  (struct-type-install-properties!
-   struct:rx:unicode-categories
    '(rx:unicode-categories)
    2
    0
@@ -1880,6 +1870,16 @@
    '(0 1)
    #f
    'rx:unicode-categories))
+(define struct:rx:unicode-categories
+  (make-record-type-descriptor*
+   'rx:unicode-categories
+   #f
+   (|#%nongenerative-uid| rx:unicode-categories)
+   #f
+   #f
+   2
+   0))
+(define effect_2341 (finish109 struct:rx:unicode-categories))
 (define rx:unicode-categories12.1
   (|#%name|
    rx:unicode-categories
@@ -2129,18 +2129,8 @@
      num-n_0
      (let ((or-part_0 (needs-backtrack? pces1_0)))
        (if or-part_0 or-part_0 (needs-backtrack? pces2_0))))))
-(define struct:parse-config
+(define finish123
-  (make-record-type-descriptor*
+  (make-struct-type-install-properties
-   'parse-config
-   #f
-   (|#%nongenerative-uid| parse-config)
-   #f
-   #f
-   7
-   0))
-(define effect_2522
-  (struct-type-install-properties!
-   struct:parse-config
    '(parse-config)
    7
    0
@@ -2151,6 +2141,16 @@
    '(0 1 2 3 4 5 6)
    #f
    'parse-config))
+(define struct:parse-config
+  (make-record-type-descriptor*
+   'parse-config
+   #f
+   (|#%nongenerative-uid| parse-config)
+   #f
+   #f
+   7
+   0))
+(define effect_2622 (finish123 struct:parse-config))
 (define parse-config1.1
   (|#%name|
    parse-config
@@ -4697,18 +4697,8 @@
                                       (zero-sized? (rx:cut-rx rx_0))
                                       #f)))))))))))))))))))
 (define union (lambda (a_0 b_0) (if a_0 (if b_0 (range-union a_0 b_0) #f) #f)))
-(define struct:lazy-bytes
+(define finish535
-  (make-record-type-descriptor*
+  (make-struct-type-install-properties
-   'lazy-bytes
-   #f
-   (|#%nongenerative-uid| lazy-bytes)
-   #f
-   #f
-   13
-   3075))
-(define effect_2409
-  (struct-type-install-properties!
-   struct:lazy-bytes
    '(lazy-bytes)
    13
    0
@@ -4719,6 +4709,16 @@
    '(2 3 4 5 6 7 8 9 12)
    #f
    'lazy-bytes))
+(define struct:lazy-bytes
+  (make-record-type-descriptor*
+   'lazy-bytes
+   #f
+   (|#%nongenerative-uid| lazy-bytes)
+   #f
+   #f
+   13
+   3075))
+(define effect_2741 (finish535 struct:lazy-bytes))
 (define lazy-bytes1.1
   (|#%name|
    lazy-bytes
@@ -7242,18 +7242,8 @@
           (if (rx:range? rx_0)
             (range-matcher* (compile-range (rx:range-range rx_0)) max_0)
             #f))))))
-(define struct:rx:regexp
+(define finish621
-  (make-record-type-descriptor*
+  (make-struct-type-install-properties
-   'regexp
-   #f
-   (|#%nongenerative-uid| regexp)
-   #f
-   #f
-   10
-   0))
-(define effect_2528
-  (struct-type-install-properties!
-   struct:rx:regexp
    '(regexp)
    10
    0
@@ -7281,6 +7271,16 @@
    '(0 1 2 3 4 5 6 7 8 9)
    #f
    'rx:regexp))
+(define struct:rx:regexp
+  (make-record-type-descriptor*
+   'regexp
+   #f
+   (|#%nongenerative-uid| regexp)
+   #f
+   #f
+   10
+   0))
+(define effect_2726 (finish621 struct:rx:regexp))
 (define rx:regexp1.1
   (|#%name|
    rx:regexp

racket/src/expander/compile/built-in-symbol.rkt

@@ -85,13 +85,14 @@
                record-accessor
                record-mutator
                record-predicate
-               struct-type-install-properties!
+               make-struct-type-install-properties
                #%struct-constructor
                #%struct-predicate
                #%struct-field-accessor
                #%struct-field-mutator
                #%nongenerative-uid
                unsafe-struct?
+               unsafe-sealed-struct?
                unsafe-struct
                raise-binding-result-arity-error
                raise-definition-result-arity-error

racket/src/expander/syntax/scope.rkt

@@ -167,6 +167,7 @@
                      shifted  ; box of table: interned shifted-multi-scopes for non-label phases
                      label-shifted) ; box of table: interned shifted-multi-scopes for label phases
   #:authentic
+  #:sealed
   #:property prop:serialize
   (lambda (ms ser-push! state)
     (ser-push! 'tag '#:multi-scope)
@@ -247,6 +248,7 @@
 (struct shifted-multi-scope (phase        ; non-label phase shift or shifted-to-label-phase
                              multi-scope) ; a multi-scope
   #:authentic
+  #:sealed
   #:property prop:custom-write
   (lambda (sms port mode)
     (write-string "#<scope:" port)
@@ -574,6 +576,7 @@
                      inspector  ; #f or inspector
                      tamper)    ; see "tamper.rkt"
   #:authentic
+  #:sealed
   #:property prop:propagation syntax-e
   #:property prop:propagation-tamper (lambda (p) (propagation-tamper p))
   #:property prop:propagation-set-tamper (lambda (p v) (propagation-set-tamper p v)))

racket/src/expander/syntax/syntax.rkt

@@ -58,6 +58,7 @@
                 props   ; properties
                 inspector) ; inspector for access to protected bindings
   #:authentic
+  #:sealed
   ;; Custom printer:
   #:property prop:custom-write
   (lambda (s port mode)

racket/src/schemify/find-definition.rkt

@@ -46,9 +46,10 @@
                                     (known-struct-constructor (arithmetic-shift 1 (struct-type-info-field-count info)) type struct:s)
                                     a-known-constant))]
               [authentic? (struct-type-info-authentic? info)]
+              [sealed? (struct-type-info-sealed? info)]
               [knowns (hash-set knowns
                                 (unwrap s?)
-                                (known-struct-predicate 2 type struct:s authentic?))]
+                                (known-struct-predicate 2 type struct:s authentic? sealed?))]
               [knowns
                (let* ([immediate-count (struct-type-info-immediate-field-count info)]
                       [parent-count (- (struct-type-info-field-count info)
@@ -76,7 +77,8 @@
                      [`,_ knowns])))])
          (values (hash-set knowns (unwrap struct:s) (known-struct-type type
                                                                        (struct-type-info-field-count info)
-                                                                       (struct-type-info-pure-constructor? info)))
+                                                                       (struct-type-info-pure-constructor? info)
+                                                                       (struct-type-info-sealed? info)))
                  info))]
       [else (values knowns #f)])]
     [`(define-values (,struct:s ,make-s ,s? ,s-ref ,s-set!) ,rhs) ; direct use of `make-struct-type`
@@ -92,11 +94,14 @@
                                      a-known-constant))]
                [knowns (hash-set knowns
                                  (unwrap s?)
-                                 (known-struct-predicate 2 type struct:s (struct-type-info-authentic? info)))])
+                                 (known-struct-predicate 2 type struct:s
+                                                         (struct-type-info-authentic? info)
+                                                         (struct-type-info-sealed? info)))])
           ;; For now, we don't try to track the position-consuming accessor or mutator
           (hash-set knowns (unwrap struct:s) (known-struct-type type
                                                                 (struct-type-info-field-count info)
-                                                                (struct-type-info-pure-constructor? info))))
+                                                                (struct-type-info-pure-constructor? info)
+                                                                (struct-type-info-sealed? info))))
         info)]
       [else (values knowns #f)])]
     [`(define-values (,prop:s ,s? ,s-ref)

racket/src/schemify/inline.rkt

@@ -266,6 +266,7 @@
                                              (known-predicate-type k)
                                              (known-struct-predicate-type-id k)
                                              (known-struct-predicate-authentic? k)
+                                             (known-struct-predicate-sealed? k)
                                              (needed->list needed))]
        [else
         (known-predicate (known-procedure-arity-mask k)

racket/src/schemify/known.rkt

@@ -29,13 +29,14 @@
          known-procedure/has-unsafe/folding/limited known-procedure/has-unsafe/folding/limited?
          known-procedure/has-unsafe/folding/limited-kind
          known-struct-type known-struct-type? known-struct-type-type
-         known-struct-type-field-count known-struct-type-pure-constructor?
+         known-struct-type-field-count known-struct-type-pure-constructor? known-struct-type-sealed?
          known-constructor known-constructor? known-constructor-type
          known-predicate known-predicate? known-predicate-type
          known-accessor known-accessor? known-accessor-type
          known-mutator known-mutator? known-mutator-type
          known-struct-constructor known-struct-constructor? known-struct-constructor-type-id
-         known-struct-predicate known-struct-predicate? known-struct-predicate-type-id known-struct-predicate-authentic?
+         known-struct-predicate known-struct-predicate? known-struct-predicate-type-id
+         known-struct-predicate-authentic? known-struct-predicate-sealed?
          known-field-accessor known-field-accessor? known-field-accessor-type-id known-field-accessor-authentic?
          known-field-accessor-pos known-field-accessor-known-immutable?
          known-field-mutator known-field-mutator? known-field-mutator-type-id known-field-mutator-authentic?
@@ -115,7 +116,7 @@
 (struct known-procedure/has-unsafe/folding () #:prefab #:omit-define-syntaxes #:super struct:known-procedure/has-unsafe)
 (struct known-procedure/has-unsafe/folding/limited (kind) #:prefab #:omit-define-syntaxes #:super struct:known-procedure/has-unsafe/folding)
 
-(struct known-struct-type (type field-count pure-constructor?) #:prefab #:omit-define-syntaxes #:super struct:known-consistent)
+(struct known-struct-type (type field-count pure-constructor? sealed?) #:prefab #:omit-define-syntaxes #:super struct:known-consistent)
 
 ;; procedures with a known connection to a structure type:
 (struct known-constructor (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure/allocates)
@@ -123,7 +124,7 @@
 (struct known-accessor (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure/single-valued)
 (struct known-mutator (type) #:prefab #:omit-define-syntaxes #:super struct:known-procedure/single-valued)
 (struct known-struct-constructor (type-id) #:prefab #:omit-define-syntaxes #:super struct:known-constructor)
-(struct known-struct-predicate (type-id authentic?) #:prefab #:omit-define-syntaxes #:super struct:known-predicate)
+(struct known-struct-predicate (type-id authentic? sealed?) #:prefab #:omit-define-syntaxes #:super struct:known-predicate)
 (struct known-field-accessor (type-id authentic? pos known-immutable?) #:prefab #:omit-define-syntaxes #:super struct:known-accessor)
 (struct known-field-mutator (type-id authentic? pos) #:prefab #:omit-define-syntaxes #:super struct:known-mutator)
 (struct known-struct-constructor/need-imports (needed) #:prefab #:omit-define-syntaxes #:super struct:known-struct-constructor)

racket/src/schemify/schemify.rkt

@@ -872,21 +872,24 @@
               (define type-id (and (pair? args)
                                    (null? (cdr args))
                                    (inline-type-id k im add-import! mutated imports)))
+              (define unsafe-struct? (if (known-struct-predicate-sealed? k)
+                                         'unsafe-sealed-struct?
+                                         'unsafe-struct?))
               (cond
                 [(not type-id) #f]
                 [(known-struct-predicate-authentic? k)
                  (define tmp (maybe-tmp (car args) 'v))
-                 (define ques `(unsafe-struct? ,tmp ,(schemify type-id 'fresh)))
+                 (define ques `(,unsafe-struct? ,tmp ,(schemify type-id 'fresh)))
                  (wrap-tmp tmp (car args)
                            ques)]
                 [else
                  (define tmp (maybe-tmp (car args) 'v))
                  (define schemified-type-id (schemify type-id 'fresh))
                  (define tmp-type-id (maybe-tmp schemified-type-id 'v))
-                 (define ques `(if (unsafe-struct? ,tmp ,tmp-type-id)
+                 (define ques `(if (,unsafe-struct? ,tmp ,tmp-type-id)
                                    #t
                                    (if (impersonator? ,tmp)
-                                       (unsafe-struct? (impersonator-val ,tmp) ,tmp-type-id)
+                                       (,unsafe-struct? (impersonator-val ,tmp) ,tmp-type-id)
                                        #f)))
                  (wrap-tmp tmp (car args)
                            (wrap-tmp tmp-type-id schemified-type-id 

racket/src/schemify/struct-convert.rkt

@@ -60,7 +60,24 @@
         (define system-opaque? (and (aim? target 'system)
                                     (or (not exports)
                                         (eq? 'no (hash-ref exports (unwrap struct:s) 'no)))))
+        (define finish!-id (and (or (pair? (struct-type-info-rest sti))
+                                    (and (struct-type-info-prefab-immutables sti)
+                                         ;; to ensure that the super is also a prefab:
+                                         (unwrap (struct-type-info-parent sti))))
+                                (deterministic-gensym "finish")))
         `(begin
+           ,@(if finish!-id
+                 `((define ,finish!-id
+                     (make-struct-type-install-properties ',(if system-opaque?
+                                                                ;; list is recognized by `struct-type-install-properties!`
+                                                                ;; to indicate a system structure type:
+                                                                (list (struct-type-info-name sti))
+                                                                (struct-type-info-name sti))
+                                                          ,(struct-type-info-immediate-field-count sti)
+                                                          0
+                                                          ,(schemify (struct-type-info-parent sti) knowns)
+                                                          ,@(schemify-body schemify knowns (struct-type-info-rest sti)))))
+                 null)
            (define ,struct:s (make-record-type-descriptor* ',(struct-type-info-name sti)
                                                            ,(schemify (struct-type-info-parent sti) knowns)
                                                            ,(if (not (struct-type-info-prefab-immutables sti))
@@ -74,7 +91,7 @@
                                                                   ,(struct-type-info-immediate-field-count sti)
                                                                   0 #f
                                                                   ',(struct-type-info-prefab-immutables sti)))
-                                                           #f
+                                                           ,(struct-type-info-sealed? sti)
                                                            #f
                                                            ,(struct-type-info-immediate-field-count sti)
                                                            ,(let* ([n (struct-type-info-immediate-field-count sti)]
@@ -91,19 +108,9 @@
                                                                          (loop (cdr imms) (bitwise-and mask m)))])))]
                                                                 [else
                                                                  mask]))))
-           ,@(if (null? (struct-type-info-rest sti))
+           ,@(if finish!-id
-                 null
+                 `((define ,(deterministic-gensym "effect") (,finish!-id ,struct:s)))
-                 `((define ,(deterministic-gensym "effect")
+                 null)
-                     (struct-type-install-properties! ,struct:s
-                                                      ',(if system-opaque?
-                                                            ;; list is recognized by `struct-type-install-properties!`
-                                                            ;; to indincate a system structure type:
-                                                            (list (struct-type-info-name sti))
-                                                            (struct-type-info-name sti))
-                                                      ,(struct-type-info-immediate-field-count sti)
-                                                      0
-                                                      ,(schemify (struct-type-info-parent sti) knowns)
-                                                      ,@(schemify-body schemify knowns (struct-type-info-rest sti))))))
            (define ,make-s ,(let ([ctr `(record-constructor
                                          (make-record-constructor-descriptor ,struct:s #f #f))])
                               (define ctr-expr

racket/src/schemify/struct-type-info.rkt

@@ -17,6 +17,7 @@
                                field-count
                                pure-constructor?
                                authentic?
+                               sealed?
                                prefab-immutables ; #f or immutable expression to be quoted
                                non-prefab-immutables ; #f or immutable expression to be quoted
                                constructor-name-expr  ; an expression
@@ -107,6 +108,7 @@
                                               (not (unwrap (list-ref rest 4))))
                                           (not (includes-property? 'prop:chaperone-unsafe-undefined)))
                                      (includes-property? 'prop:authentic)
+                                     (includes-property? 'prop:sealed)
                                      (if (eq? prefab-imms 'non-prefab)
                                          #f
                                          prefab-imms)

racket/src/thread/thread.rkt

@@ -131,6 +131,7 @@
 
                      [future #:mutable])  ; current would-be future
   #:authentic
+  #:sealed
   #:property host:prop:unsafe-authentic-override #t ; allow evt chaperone
   #:property prop:waiter
   (make-waiter-methods 

racket/src/version/racket_version.h

@@ -16,7 +16,7 @@
 #define MZSCHEME_VERSION_X 8
 #define MZSCHEME_VERSION_Y 0
 #define MZSCHEME_VERSION_Z 0
-#define MZSCHEME_VERSION_W 6
+#define MZSCHEME_VERSION_W 7
 
 /* A level of indirection makes `#` work as needed: */
 #define AS_a_STR_HELPER(x) #x