Export an alternative object/c constructor

This functional constructor allows runtime construction
of object contracts in extension libraries.

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

@@ -2076,6 +2076,17 @@ Produces a contract for an object, where the object is an
 instance of a class that conforms to @racket[class-contract].
 }
 
+@defproc[(dynamic-object/c [method-names (listof symbol?)]
+                           [method-contracts (listof contract?)]
+                           [field-names (listof symbol?)]
+                           [field-contracts (listof contract?)])
+         contract?]{
+Produces a contract for an object, similar to @racket[object/c] but
+where the names and contracts for both methods and fields can be
+computed dynamically. The list of names and contracts for both
+methods and field respectively must have the same lengths.
+}
+
 @defform/subs[
 #:literals (field -> ->* ->d)
 

pkgs/racket-test/tests/racket/contract/object.rkt

@@ -17,6 +17,13 @@
             'pos
             'neg))
 
+(test/spec-passed
+ 'object/c-first-order-object-3
+ '(contract (dynamic-object/c null null null null)
+            (new object%)
+            'pos
+            'neg))
+
 (test/pos-blame
  'object/c-first-order-method-1
  '(contract (object/c [m (-> any/c number? number?)])
@@ -31,6 +38,13 @@
             'pos
             'neg))
 
+(test/spec-passed
+ 'object/c-first-order-method-3
+ '(contract (dynamic-object/c '(m) (list (-> any/c number? number?)) null null)
+            (new (class object% (super-new) (define/public (m x) (add1 x))))
+            'pos
+            'neg))
+
 (test/pos-blame
  'object/c-first-order-local-method-1
  '(let ()
@@ -63,6 +77,13 @@
             'pos
             'neg))
 
+(test/spec-passed
+ 'object/c-first-order-field-3
+ '(contract (dynamic-object/c null null '(n) (list number?))
+            (new (class object% (super-new) (field [n 3])))
+            'pos
+            'neg))
+
 (test/pos-blame
  'object/c-first-order-local-field-1
  '(let ()
@@ -158,4 +179,42 @@
                       'pos
                       'neg)])
     (set-field! n pre-o #t)
-    (get-field n o))))
+    (get-field n o)))
+
+(test/pos-blame
+ 'object/c-higher-order-field-9
+ '(let* ([pre-o (new (class object% (super-new) (field [n 3])))]
+         [o (contract (dynamic-object/c null null '(n) (list number?))
+                      pre-o
+                      'pos
+                      'neg)])
+    (set-field! n pre-o #t)
+    (get-field n o)))
+
+(test/spec-passed/result
+ 'object/c-field-existence
+ '(send (contract
+         (object/c
+          (field foo bar)
+          (baz (->m integer? integer?)))
+         (new (class object%
+                (super-new)
+                (field (foo 0) (bar 0))
+                (define/public (baz n) n)))
+         'pos 'neg)
+        baz 1)
+ 1)
+
+(test/spec-passed/result
+ 'object/c-field-existence2
+ '(send (contract
+         (object/c
+          (field foo bar)
+          (baz (->m integer? (listof integer?))))
+         (new (class object%
+                (super-new)
+                (field (foo 0) (bar 1))
+                (define/public (baz n) (list foo bar))))
+         'pos 'neg)
+        baz 1)
+ '(0 1)))

racket/collects/racket/private/class-c-old.rkt

@@ -19,7 +19,8 @@
          (struct-out internal-class/c)
          just-check-existence just-check-existence?
          build-internal-class/c internal-class/c-proj
-         class/c-internal-name-clauses)
+         class/c-internal-name-clauses
+         dynamic-object/c)
 
 ;; Shorthand contracts that treat the implicit object argument as if it were
 ;; contracted with any/c.
@@ -1201,6 +1202,31 @@
           #:key (compose symbol->string car)))
   (values (map car sorted) (map cdr sorted)))
 
+;; dynamic-object/c : Listof<Symbol> Listof<Contract>
+;;                    Listof<Symbol> Listof<Contract>
+;;                    -> Contract
+;; An external constructor provided in order to allow runtime
+;; construction of object contracts by libraries that want to
+;; implement their own object contract variants
+(define (dynamic-object/c method-names method-contracts
+                          field-names field-contracts)
+  (define (ensure-symbols names)
+    (unless (and (list? names) (andmap symbol? names))
+      (raise-argument-error 'dynamic-object/c "(listof symbol?)" names)))
+  (define (ensure-length names ctcs)
+    (unless (= (length names) (length ctcs))
+      (raise-arguments-error 'dynamic-object/c
+                             "expected the same number of names and contracts"
+                             "names" names
+                             "contracts" ctcs)))
+  (ensure-symbols method-names)
+  (ensure-length method-names method-contracts)
+  (ensure-symbols field-names)
+  (ensure-length field-names field-contracts)
+  (make-base-object/c
+   method-names (coerce-contracts 'dynamic-object/c method-contracts)
+   field-names (coerce-contracts 'dynamic-object/c field-contracts)))
+
 (define (check-object-contract obj methods fields fail)
   (unless (object? obj)
     (fail '(expected: "an object" given: "~e") obj))

racket/collects/racket/private/class-internal.rkt

@@ -62,6 +62,7 @@
            (struct-out exn:fail:object)
            make-primitive-class
            class/c ->m ->*m ->dm case->m object/c instanceof/c
+           dynamic-object/c
            
            ;; "keywords":
            private public override augment