added list-contract?

and specialized a bunch of list-related contracts to track list?-ness,
notably recursive-contract now accepts a #:list-contract? argument
that means that it insists that values it accepts be list? (and
thus not cyclic)

related to PR 14559

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

@@ -187,6 +187,9 @@ For example, this contract
 does not accept a function like this one: @racket[(lambda args ...)]
 since it cannot tell which of the two arrow contracts should be used
 with the function.
+
+If all of its arguments are @racket[list-contract?]s, then @racket[or/c]
+returns a @racket[list-contract?].
 }
 
 @defproc[(and/c [contract contract?] ...) contract?]{
@@ -369,14 +372,14 @@ Returns the same contract as @racket[(box/c c #:immutable #t)]. This form exists
 reasons of backwards compatibility.}
 
 
-@defproc[(listof [c contract?]) contract?]{
+@defproc[(listof [c contract?]) list-contract?]{
 
 Returns a contract that recognizes a list whose every element matches
 the contract @racket[c]. Beware that when this contract is applied to
 a value, the result is not necessarily @racket[eq?] to the input.}
 
 
-@defproc[(non-empty-listof [c contract?]) contract?]{
+@defproc[(non-empty-listof [c contract?]) list-contract?]{
 
 Returns a contract that recognizes non-empty lists whose elements match
 the contract @racket[c]. Beware that when this contract is applied to
@@ -387,10 +390,16 @@ a value, the result is not necessarily @racket[eq?] to the input.}
 Produces a contract that recognizes pairs whose first and second elements
 match @racket[car-c] and @racket[cdr-c], respectively. Beware that
 when this contract is applied to a value, the result is not
-necessarily @racket[eq?] to the input.}
+necessarily @racket[eq?] to the input.
+
+If the @racket[cdr-c] contract is a @racket[list-contract?], then 
+@racket[cons/c] returns a @racket[list-contract?].
+
+@history[#:changed "6.0.1.13" @list{Added the @racket[list-contract?] propagating behavior.}]
+}
 
 
-@defproc[(list/c [c contract?] ...) contract?]{
+@defproc[(list/c [c contract?] ...) list-contract?]{
 
 Produces a contract for a list. The number of elements in the list
 must match the number of arguments supplied to @racket[list/c], and
@@ -1858,7 +1867,8 @@ the contract library primitives below.
                   name x))))]
           [#:stronger stronger
                       (or/c #f (-> contract? contract? boolean?))
-                      #f])
+                      #f]
+          [#:list-contract is-list-contract? boolean? #f])
          contract?]
 @defproc[(make-chaperone-contract
           [#:name name any/c 'anonymous-chaperone-contract]
@@ -1878,7 +1888,8 @@ the contract library primitives below.
                   name x))))]
           [#:stronger stronger
                       (or/c #f (-> contract? contract? boolean?))
-                      #f])
+                      #f]
+          [#:list-contract is-list-contract? boolean? #f])
          chaperone-contract?]
 @defproc[(make-flat-contract
           [#:name name any/c 'anonymous-flat-contract]
@@ -1898,7 +1909,8 @@ the contract library primitives below.
                   name x))))]
           [#:stronger stronger
                       (or/c #f (-> contract? contract? boolean?))
-                      #f])
+                      #f]
+          [#:list-contract is-list-contract? boolean? #f])
          flat-contract?]
 )]{
 
@@ -1946,6 +1958,9 @@ The @racket[stronger] argument is used to implement @racket[contract-stronger?].
 first argument is always the contract itself and the second argument is whatever
 was passed as the second argument to @racket[contract-stronger?].
 
+The @racket[is-list-contract?] argument is used by the @racket[list-contract?] predicate
+to determine if this is a contract that accepts only @racket[list?] values.
+
 @defexamples[#:eval (contract-eval)
 (define int/c
   (make-flat-contract #:name 'int/c #:first-order integer?))
@@ -1977,6 +1992,7 @@ was passed as the second argument to @racket[contract-stronger?].
 (halve 1)
 ]
 
+@history[#:changed "6.0.1.13" @list{Added the @racket[#:list-contract?] argument.}]
 }
 
 @defproc[(build-compound-type-name [c/s any/c] ...) any]{
@@ -2306,7 +2322,8 @@ is expected to be the blame record for the contract on the value).
                   (-> (and/c positive? real?)
                       (values
                        (-> c void?)
-                       (listof contract?)))]))])
+                       (listof contract?)))]))]
+          [#:list-contract? is-list-contract? (-> contract? boolean?) (λ (c) #f)])
          flat-contract-property?]
 @defproc[(build-chaperone-contract-property
           [#:name
@@ -2353,7 +2370,8 @@ is expected to be the blame record for the contract on the value).
                   (-> (and/c positive? real?)
                       (values
                        (-> c void?)
-                       (listof contract?)))]))])
+                       (listof contract?)))]))]
+          [#:list-contract? is-list-contract? (-> contract? boolean?) (λ (c) #f)])
          chaperone-contract-property?]
 @defproc[(build-contract-property
           [#:name
@@ -2400,7 +2418,8 @@ is expected to be the blame record for the contract on the value).
                   (-> (and/c positive? real?)
                       (values
                        (-> c void?)
-                       (listof contract?)))]))])
+                       (listof contract?)))]))]
+          [#:list-contract? is-list-contract? (-> contract? boolean?) (λ (c) #f)])
          contract-property?])]{
 
       @italic{The precise details of the 
@@ -2423,10 +2442,12 @@ produces a blame-tracking projection defining the behavior of the contract;
 (passed in the first argument) is stronger than some other contract (passed
 in the second argument); @racket[generate], which returns a thunk
 that generates random values matching the contract or @racket[#f], indicating
-that random generation for this contract isn't supported; and @racket[exercise],
+that random generation for this contract isn't supported; @racket[exercise],
 which returns a function that exercises values matching the contract (e.g.,
 if it is a function contract, it may call the function) and a list of contracts
-whose values will be generated by this process.
+whose values will be generated by this process; and @racket[is-flat-contract?],
+which is used by @racket[flat-contract?] to determine if this contract
+accepts only @racket[list?]s.
 
 These accessors are passed as (optional) keyword arguments to
 @racket[build-contract-property], and are applied to instances of the
@@ -2448,6 +2469,7 @@ projection accessor is expected not to wrap its argument in a higher-order
 fashion, analogous to the constraint on projections in
 @racket[make-flat-contract].
 
+@history[#:changed "6.0.1.13" @list{Added the @racket[#:list-contract?] argument.}]
 }
 
 @deftogether[(
@@ -2628,6 +2650,17 @@ symbols, booleans, numbers, and other ordinary Racket values
 (that are defined as @tech{contracts}) are also
 flat contracts.}
 
+@defproc[(list-contract? [v any/c]) boolean?]{
+  Recognizes certain @racket[contract?] values that accept @racket[list?]s.
+  
+  A list contract is one that insists that its argument
+  is a @racket[list?], meaning that the value cannot be cyclic
+  and must either be the empty list or a pair constructed
+  with @racket[cons] and another list.
+  
+  @history[#:added "6.0.1.13"]
+}
+
 @defproc[(contract-name [c contract?]) any/c]{
 Produces the name used to describe the contract in error messages.
 }
@@ -2670,13 +2703,22 @@ Makes a contract that accepts no values, and reports the
 name @racket[sexp-name] when signaling a contract violation.}
 
 @defform*[[(recursive-contract contract-expr)
-           (recursive-contract contract-expr type)]]{
+           (recursive-contract contract-expr #:list-contract?)
+           (recursive-contract contract-expr type)
+           (recursive-contract contract-expr type #:list-contract?)]]{
 
 Delays the evaluation of its argument until the contract is checked,
 making recursive contracts possible.  If @racket[type] is given, it
 describes the expected type of contract and must be one of the keywords
 @racket[#:impersonator], @racket[#:chaperone], or @racket[#:flat].  If
-@racket[type] is not given, an impersonator contract is created.}
+@racket[type] is not given, an impersonator contract is created.
+
+If @racket[#:list-contract?] is returned, then the result is a
+@racket[list-contract?] and the @racket[contract-expr] must evaluate
+to a @racket[list-contract?].
+
+@history[#:changed "6.0.1.13" @list{Added the @racket[#:list-contract?] argument.}]
+}
 
 
 @defform/subs[(opt/c contract-expr maybe-name)

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

@@ -0,0 +1,114 @@
+#lang racket/base
+(require "test-util.rkt")
+(parameterize ([current-contract-namespace (make-basic-contract-namespace 'racket/list)])
+  
+  (test/spec-passed/result
+   'list-contract-1
+   '(list-contract? 1)
+   #f)
+  
+  (test/spec-passed/result
+   'list-contract-2
+   '(list-contract? (λ (a b c) a)) ;; somethign that's not coerceable to a contract
+   #f)
+  
+  (test/spec-passed/result
+   'list-contract-3
+   '(list-contract? '())
+   #t)
+  
+  (test/spec-passed/result
+   'list-contract-4
+   '(list-contract? null?)
+   #t)
+  
+  (test/spec-passed/result
+   'list-contract-5
+   '(list-contract? empty?)
+   #t)
+  
+  (test/spec-passed/result
+   'list-contract-6
+   '(list-contract? boolean?)
+   #f)
+  
+  (test/spec-passed/result
+   'list-contract-7
+   '(list-contract? any/c)
+   #f)
+  
+  (test/spec-passed/result
+   'list-contract-8
+   '(list-contract? (cons/c 1 empty?))
+   #t)
+  
+  (test/spec-passed/result
+   'list-contract-9
+   '(list-contract? (cons/c 1 2))
+   #f)
+  
+  (test/spec-passed/result
+   'list-contract-10
+   '(list-contract? (listof any/c))
+   #t)
+  
+  (test/spec-passed/result
+   'list-contract-11
+   '(list-contract? (non-empty-listof any/c))
+   #t)
+  
+  (test/spec-passed/result
+   'list-contract-12
+   '(list-contract? (list/c 1 2 3))
+   #t)
+  
+  (test/spec-passed/result
+   'list-contract-13
+   '(list-contract? (or/c (cons/c 1 empty?) empty?))
+   #t)
+  
+  (test/spec-passed/result
+   'list-contract-14
+   '(list-contract? (or/c (cons/c (-> integer? integer?) empty?)
+                          empty?))
+   #t)
+  
+  (test/spec-passed/result
+   'list-contract-15
+   '(list-contract? (or/c (cons/c (-> integer? integer?) empty?)
+                          (cons/c (-> integer? integer? integer?) empty?)
+                          empty?))
+   #t)
+  
+  (test/spec-passed/result
+   'list-contract-16
+   '(list-contract? 
+     (letrec ([c (recursive-contract (or/c (cons/c 1 c) empty?))])
+       c))
+   #f)
+  
+  (test/spec-passed/result
+   'list-contract-17
+   '(list-contract? 
+     (letrec ([c (recursive-contract (or/c (cons/c 1 c) empty?) #:list-contract?)])
+       c))
+   #t)
+  
+  (test/pos-blame
+   'test-contract-18
+   '(contract (letrec ([c (recursive-contract (or/c (cons/c any/c c) empty?) 
+                                              #:list-contract?)])
+                c)
+              (read (open-input-string "#1=(1 . #1#)"))
+              'pos 'neg))
+  
+  
+  (contract-error-test
+   'test-contract-19
+   '(contract (recursive-contract 1 #:list-contract?)
+              1
+              'pos 'neg)
+   (λ (x)
+     (and (exn:fail? x)
+          (regexp-match #rx"list-contract[?]" (exn-message x))))))
+

racket/collects/racket/contract/base.rkt

@@ -67,6 +67,7 @@
  has-blame?
  value-blame
  contract-continuation-mark-key
+ list-contract?
  
  ;; from private/case-arrow.rkt
  case->)

racket/collects/racket/contract/private/base.rkt

@@ -103,7 +103,7 @@
                    '#,(build-source-location-vector #'ctc))))]))
 
 (define-syntax (-recursive-contract stx)
-  (define (do-recursive-contract arg type name)
+  (define (do-recursive-contract arg type name list-contract?)
     (define local-name (syntax-local-infer-name stx))
     (define maker
       (case (syntax-e type)
@@ -115,13 +115,18 @@
                "type must be one of #:impersonator, #:chaperone, or #:flat"
                stx
                type)]))
-    #`(#,maker '#,name (λ () #,arg) '#,local-name))
+    #`(#,maker '#,name (λ () #,arg) '#,local-name #,list-contract?))
   (syntax-case stx ()
+    [(_ arg type #:list-contract?)
+     (keyword? (syntax-e #'type))
+     (do-recursive-contract #'arg #'type #'(recursive-contract arg type) #t)]
+    [(_ arg #:list-contract?)
+     (do-recursive-contract #'arg #'#:impersonator #'(recursive-contract arg) #t)]
     [(_ arg type)
      (keyword? (syntax-e #'type))
-     (do-recursive-contract #'arg #'type #'(recursive-contract arg type))]
+     (do-recursive-contract #'arg #'type #'(recursive-contract arg type) #f)]
     [(_ arg)
-     (do-recursive-contract #'arg #'#:impersonator #'(recursive-contract arg))]))
+     (do-recursive-contract #'arg #'#:impersonator #'(recursive-contract arg) #f)]))
 
 (define (force-recursive-contract ctc)
   (define current (recursive-contract-ctc ctc))
@@ -138,19 +143,37 @@
           (coerce-chaperone-contract 'recursive-contract (thunk))]
          [(impersonator-recursive-contract? ctc)
           (coerce-contract 'recursive-contract (thunk))]))
+     (when (recursive-contract-list-contract? ctc)
+       (unless (list-contract? forced-ctc)
+         (raise-argument-error 'recursive-contract "list-contract?" forced-ctc)))
      (set-recursive-contract-ctc! ctc forced-ctc)
      (set-recursive-contract-name! ctc (append `(recursive-contract ,(contract-name forced-ctc))
                                                (cddr old-name)))
      forced-ctc]
     [else current]))
 
-(define ((recursive-contract-projection ctc) blame)
+(define (recursive-contract-projection ctc)
-  (define r-ctc (force-recursive-contract ctc))
+  (cond
-  (define f (contract-projection r-ctc))
+    [(recursive-contract-list-contract? ctc)
-  (define blame-known (blame-add-context blame #f))
+     (λ (blame)
-  (λ (val)
+       (define r-ctc (force-recursive-contract ctc))
-    ((f blame-known) val)))
+       (define f (contract-projection r-ctc))
-
+       (define blame-known (blame-add-context blame #f))
+       (λ (val)
+         (unless (list? val)
+           (raise-blame-error blame-known
+                              val
+                              '(expected: "list?" given: "~e")
+                              val))
+         ((f blame-known) val)))]
+    [else
+     (λ (blame)
+       (define r-ctc (force-recursive-contract ctc))
+       (define f (contract-projection r-ctc))
+       (define blame-known (blame-add-context blame #f))
+       (λ (val)
+         ((f blame-known) val)))]))
+  
 (define (recursive-contract-stronger this that)
   (and (recursive-contract? that)
        (procedure-closure-contents-eq? (recursive-contract-thunk this)
@@ -160,7 +183,7 @@
   (contract-first-order-passes? (force-recursive-contract ctc)
                                 val))
 
-(struct recursive-contract ([name #:mutable] thunk [ctc #:mutable]))
+(struct recursive-contract ([name #:mutable] thunk [ctc #:mutable] list-contract?))
 
 (struct flat-recursive-contract recursive-contract ()
   #:property prop:custom-write custom-write-property-proc
@@ -169,7 +192,8 @@
    #:name recursive-contract-name
    #:first-order recursive-contract-first-order
    #:projection recursive-contract-projection
-   #:stronger recursive-contract-stronger))
+   #:stronger recursive-contract-stronger
+   #:list-contract? recursive-contract-list-contract?))
 (struct chaperone-recursive-contract recursive-contract ()
   #:property prop:custom-write custom-write-property-proc
   #:property prop:chaperone-contract
@@ -177,7 +201,8 @@
    #:name recursive-contract-name
    #:first-order recursive-contract-first-order
    #:projection recursive-contract-projection
-   #:stronger recursive-contract-stronger))
+   #:stronger recursive-contract-stronger
+   #:list-contract? recursive-contract-list-contract?))
 (struct impersonator-recursive-contract recursive-contract ()
   #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
@@ -185,4 +210,5 @@
    #:name recursive-contract-name
    #:first-order recursive-contract-first-order
    #:projection recursive-contract-projection
-   #:stronger recursive-contract-stronger))
+   #:stronger recursive-contract-stronger
+   #:list-contract? recursive-contract-list-contract?))

racket/collects/racket/contract/private/guts.rkt

@@ -6,6 +6,7 @@
          "rand.rkt"
          "generate-base.rkt"
          racket/pretty
+         racket/list
          (for-syntax racket/base
                      "helpers.rkt"))
 
@@ -20,7 +21,8 @@
          build-compound-type-name
          
          contract-stronger?
-
+         list-contract?
+         
          contract-first-order
          contract-first-order-passes?
          
@@ -123,6 +125,10 @@
     (coerce-contract 'contract-first-order-passes? c))
    v))
 
+(define (list-contract? raw-c)
+  (define c (coerce-contract/f raw-c))
+  (and c (contract-struct-list-contract? c)))
+
 ;; contract-stronger? : contract contract -> boolean
 ;; indicates if one contract is stronger (ie, likes fewer values) than another
 ;; this is not a total order.
@@ -207,6 +213,7 @@
                               x 
                               #f 
                               (memq x the-known-good-contracts))]
+    [(null? x) (make-eq-contract x)]
     [(or (symbol? x) (boolean? x) (char? x) (null? x) (keyword? x)) (make-eq-contract x)]
     [(or (bytes? x) (string? x)) (make-equal-contract x)]
     [(number? x) (make-=-contract x)]
@@ -356,7 +363,8 @@
               (eq? this-val (eq-contract-val that)))
          (and (predicate-contract? that)
               (predicate-contract-sane? that)
-              ((predicate-contract-pred that) this-val))))))
+              ((predicate-contract-pred that) this-val))))
+   #:list-contract? (λ (c) (null? (eq-contract-val c)))))
 
 (define-struct equal-contract (val)
   #:property prop:custom-write custom-write-property-proc
@@ -451,7 +459,9 @@
                                        (predicate-contract-name ctc)))
                       (λ (fuel)
                         (and built-in-generator
-                             (λ () (built-in-generator fuel))))])))))
+                             (λ () (built-in-generator fuel))))])))
+   #:list-contract? (λ (ctc) (or (equal? (predicate-contract-pred ctc) null?)
+                                 (equal? (predicate-contract-pred ctc) empty?)))))
 
 (define (check-flat-named-contract predicate) (coerce-flat-contract 'flat-named-contract predicate))
 (define (check-flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))

racket/collects/racket/contract/private/misc.rkt

@@ -466,7 +466,8 @@
         #:projection (listof-*-ho-check (λ (p v) (for-each p v) v))
         #:val-first-projection (listof-*-val-first-flat-proj predicate? ctc)
         #:generate (generate ctc)
-        #:exercise (exercise ctc))]
+        #:exercise (exercise ctc)
+        #:list-contract? #t)]
       [(chaperone-contract? ctc)
        (make-chaperone-contract
         #:name ctc-name
@@ -474,14 +475,16 @@
         #:projection (listof-*-ho-check (λ (p v) (map p v)))
         #:val-first-projection (listof-*-val-first-ho-proj predicate? ctc)
         #:generate (generate ctc)
-        #:exercise (exercise ctc))]
+        #:exercise (exercise ctc)
+        #:list-contract? #t)]
       [else
        (make-contract
         #:name ctc-name
         #:first-order fo-check
         #:val-first-projection (listof-*-val-first-ho-proj predicate? ctc)
         #:projection (listof-*-ho-check (λ (p v) (map p v)))
-        #:exercise (exercise ctc))])))
+        #:exercise (exercise ctc)
+        #:list-contract? #t)])))
 
 (define (listof-*-val-first-flat-proj predicate? ctc)
   (define vf-proj (get/build-val-first-projection ctc))
@@ -593,6 +596,9 @@
          cdr-gen
          (λ () (cons (car-gen) (cdr-gen))))))
 
+(define (cons/c-list-contract? c)
+  (list-contract? (the-cons/c-tl-ctc c)))
+
 (define-struct the-cons/c (hd-ctc tl-ctc))
 (define-struct (flat-cons/c the-cons/c) ()
   #:property prop:custom-write custom-write-property-proc
@@ -603,7 +609,8 @@
    #:name cons/c-name
    #:first-order cons/c-first-order
    #:stronger cons/c-stronger?
-   #:generate cons/c-generate))
+   #:generate cons/c-generate
+   #:list-contract? cons/c-list-contract?))
 (define-struct (chaperone-cons/c the-cons/c) ()
   #:property prop:custom-write custom-write-property-proc
   #:property prop:chaperone-contract
@@ -614,7 +621,8 @@
      #:name cons/c-name
      #:first-order cons/c-first-order
      #:stronger cons/c-stronger?
-     #:generate cons/c-generate)))
+     #:generate cons/c-generate
+     #:list-contract? cons/c-list-contract?)))
 (define-struct (impersonator-cons/c the-cons/c) ()
   #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
@@ -624,7 +632,8 @@
    #:name cons/c-name
    #:first-order cons/c-first-order
    #:stronger cons/c-stronger?
-   #:generate cons/c-generate))
+   #:generate cons/c-generate
+   #:list-contract? cons/c-list-contract?))
 
 (define/subexpression-pos-prop (cons/c a b)
   (define ctc-car (coerce-contract 'cons/c a))
@@ -748,7 +757,8 @@
              (((contract-projection arg/c) 
                (add-list-context blame i))
               v))
-           x))))))
+           x))))
+   #:list-contract? (λ (c) #t)))
 
 (define (list/c-chaperone/other-projection c)
   (define args (map contract-projection (generic-list/c-args c)))
@@ -830,7 +840,8 @@
      #:generate list/c-generate
      #:exercise list/c-exercise
      #:projection list/c-chaperone/other-projection
-     #:val-first-projection list/c-chaperone/other-val-first-projection)))
+     #:val-first-projection list/c-chaperone/other-val-first-projection
+     #:list-contract? (λ (c) #t))))
 
 (struct higher-order-list/c generic-list/c ()
   #:property prop:custom-write custom-write-property-proc
@@ -841,7 +852,8 @@
    #:generate list/c-generate
    #:exercise list/c-exercise
    #:projection list/c-chaperone/other-projection
-   #:val-first-projection list/c-chaperone/other-val-first-projection))
+   #:val-first-projection list/c-chaperone/other-val-first-projection
+   #:list-contract? (λ (c) #t)))
 
 (define/subexpression-pos-prop (syntax/c ctc-in)
   (let ([ctc (coerce-flat-contract 'syntax/c ctc-in)])

racket/collects/racket/contract/private/orc.rkt

@@ -168,6 +168,11 @@
               [else (option)])])))]
     [else #f]))
 
+(define (single-or/c-list-contract? c)
+  (and (list-contract? (single-or/c-ho-ctc c))
+       (for/and ([c (in-list (single-or/c-flat-ctcs c))])
+         (list-contract? c))))
+
 (define-struct single-or/c (name pred flat-ctcs ho-ctc)
   #:property prop:orc-contract
   (λ (this) (cons (single-or/c-ho-ctc this) 
@@ -186,7 +191,8 @@
      #:generate (λ (ctc) (or/c-generate ctc
                                         (cons (single-or/c-ho-ctc ctc)
                                               (single-or/c-flat-ctcs ctc))))
-     #:exercise (λ (ctc) (or/c-exercise (list (single-or/c-ho-ctc ctc)))))))
+     #:exercise (λ (ctc) (or/c-exercise (list (single-or/c-ho-ctc ctc))))
+     #:list-contract? single-or/c-list-contract?)))
 
 (define-struct (impersonator-single-or/c single-or/c) ()
   #:property prop:custom-write custom-write-property-proc
@@ -200,7 +206,8 @@
    #:generate (λ (ctc) (or/c-generate ctc
                                       (cons (single-or/c-ho-ctc ctc)
                                             (single-or/c-flat-ctcs ctc))))
-   #:exercise (λ (ctc) (or/c-exercise (list (single-or/c-ho-ctc ctc))))))
+   #:exercise (λ (ctc) (or/c-exercise (list (single-or/c-ho-ctc ctc))))
+   #:list-contract? single-or/c-list-contract?))
 
 (define (multi-or/c-proj ctc)
   (let* ([ho-contracts (multi-or/c-ho-ctcs ctc)]
@@ -319,6 +326,12 @@
                   (andmap contract-stronger? this-ctcs that-ctcs))))
       (generic-or/c-stronger? this that)))
 
+(define (mult-or/c-list-contract? c)
+  (and (for/and ([c (in-list (multi-or/c-flat-ctcs c))])
+         (list-contract? c))
+       (for/and ([c (in-list (multi-or/c-ho-ctcs c))])
+         (list-contract? c))))
+
 (define-struct multi-or/c (name flat-ctcs ho-ctcs)
   #:property prop:orc-contract
   (λ (this) (append (multi-or/c-ho-ctcs this) 
@@ -337,7 +350,8 @@
      #:generate (λ (ctc) (or/c-generate ctc
                                         (append (multi-or/c-ho-ctcs ctc)
                                                 (multi-or/c-flat-ctcs ctc))))
-     #:exercise (λ (ctc) (or/c-exercise (multi-or/c-ho-ctcs ctc))))))
+     #:exercise (λ (ctc) (or/c-exercise (multi-or/c-ho-ctcs ctc)))
+     #:list-contract? mult-or/c-list-contract?)))
 
 (define-struct (impersonator-multi-or/c multi-or/c) ()
   #:property prop:custom-write custom-write-property-proc
@@ -351,7 +365,8 @@
    #:generate (λ (ctc) (or/c-generate ctc
                                       (append (multi-or/c-ho-ctcs ctc)
                                               (multi-or/c-flat-ctcs ctc))))
-   #:exercise (λ (ctc) (or/c-exercise (multi-or/c-ho-ctcs ctc)))))
+   #:exercise (λ (ctc) (or/c-exercise (multi-or/c-ho-ctcs ctc)))
+   #:list-contract? mult-or/c-list-contract?))
 
 (define-struct flat-or/c (pred flat-ctcs)
   #:property prop:custom-write custom-write-property-proc
@@ -396,8 +411,11 @@
 
    #:first-order
    (λ (ctc) (flat-or/c-pred ctc))
-   #:generate (λ (ctc) (or/c-generate ctc (flat-or/c-flat-ctcs ctc)))))
+   #:generate (λ (ctc) (or/c-generate ctc (flat-or/c-flat-ctcs ctc)))
-
+   #:list-contract? 
+   (λ (ctc)
+     (for/and ([c (in-list (flat-or/c-flat-ctcs ctc))])
+       (list-contract? c)))))
 
 
 (define/final-prop (symbols s1 . s2s)

racket/collects/racket/contract/private/prop.rkt

@@ -13,6 +13,7 @@
          contract-struct-stronger?
          contract-struct-generate
          contract-struct-exercise
+         contract-struct-list-contract?
          
          prop:flat-contract
          flat-contract-struct?
@@ -55,7 +56,8 @@
                                    stronger
                                    generate
                                    exercise
-                                   val-first-projection ]
+                                   val-first-projection
+                                   list-contract? ]
   #:omit-define-syntaxes)
 
 (define (contract-property-guard prop info)
@@ -121,6 +123,10 @@
       (exercise c)
       (λ (fuel) (values void '()))))
 
+(define (contract-struct-list-contract? c)
+  (define prop (contract-struct-property c))
+  ((contract-property-list-contract? prop) c))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
 ;;  Chaperone Contract Property
@@ -215,7 +221,8 @@
          #:val-first-projection [get-val-first-projection #f]
          #:stronger [stronger #f]
          #:generate [generate (λ (ctc) (λ (fuel) #f))]
-         #:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))])
+         #:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))]
+         #:list-contract? [list-contract? (λ (c) #f)])
   
   ;; this code is here to help me find the combinators that
   ;; are still using only #:projection and not #:val-first-projection
@@ -242,10 +249,16 @@
                    get-name get-first-order)])]
          [stronger (or stronger weakest)])
 
-    (mk get-name get-first-order get-projection stronger generate exercise get-val-first-projection)))
+    (mk get-name get-first-order
+        get-projection stronger 
+        generate exercise 
+        get-val-first-projection 
+        list-contract?)))
 
 (define build-contract-property
-  (build-property make-contract-property 'anonymous-contract values))
+  (procedure-rename
+   (build-property make-contract-property 'anonymous-contract values)
+   'build-contract-property))
 
 ;; Here we'll force the projection to always return the original value,
 ;; instead of assuming that the provided projection does so appropriately.
@@ -257,9 +270,11 @@
           (λ (v) (p v) v))))))
 
 (define build-flat-contract-property
-  (build-property (compose make-flat-contract-property make-contract-property)
+  (procedure-rename
-                  'anonymous-flat-contract
+   (build-property (compose make-flat-contract-property make-contract-property)
-                  flat-projection-wrapper))
+                   'anonymous-flat-contract
+                   flat-projection-wrapper)
+   'build-flat-contract-property))
 
 (define (chaperone-projection-wrapper f)
   (λ (c)
@@ -279,9 +294,11 @@
       (c-proj (blame-add-unknown-context blame)))))
 
 (define build-chaperone-contract-property
-  (build-property (compose make-chaperone-contract-property make-contract-property)
+  (procedure-rename
-                  'anonymous-chaperone-contract
+   (build-property (compose make-chaperone-contract-property make-contract-property)
-                  chaperone-projection-wrapper))
+                   'anonymous-chaperone-contract
+                   chaperone-projection-wrapper)
+   'build-chaperone-contract-property))
 
 (define (get-any? c) any?)
 (define (any? x) #t)
@@ -309,7 +326,7 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (define-struct make-contract [ name first-order projection val-first-projection 
-                                    stronger generate exercise ]
+                                    stronger generate exercise list-contract? ]
   #:omit-define-syntaxes
   #:property prop:custom-write
   (λ (stct port display?)
@@ -324,10 +341,11 @@
    #:val-first-projection (lambda (c) (make-contract-val-first-projection c))
    #:stronger (lambda (a b) ((make-contract-stronger a) a b))
    #:generate (lambda (c) (make-contract-generate c))
-   #:exercise (lambda (c) (make-contract-exercise c))))
+   #:exercise (lambda (c) (make-contract-exercise c))
+   #:list-contract? (λ (c) (make-contract-list-contract? c))))
 
 (define-struct make-chaperone-contract [ name first-order projection val-first-projection
-                                              stronger generate exercise ]
+                                              stronger generate exercise list-contract? ]
   #:omit-define-syntaxes
   #:property prop:custom-write
   (λ (stct port display?)
@@ -342,10 +360,11 @@
    #:val-first-projection (lambda (c) (make-chaperone-contract-val-first-projection c))
    #:stronger (lambda (a b) ((make-chaperone-contract-stronger a) a b))
    #:generate (lambda (c) (make-chaperone-contract-generate c))
-   #:exercise (lambda (c) (make-chaperone-contract-exercise c))))
+   #:exercise (lambda (c) (make-chaperone-contract-exercise c))
+   #:list-contract? (λ (c) (make-chaperone-contract-list-contract? c))))
 
 (define-struct make-flat-contract [ name first-order projection val-first-projection
-                                         stronger generate exercise ]
+                                         stronger generate exercise list-contract? ]
   #:omit-define-syntaxes
   #:property prop:custom-write
   (λ (stct port display?)
@@ -360,7 +379,8 @@
    #:projection (lambda (c) (make-flat-contract-projection c))
    #:stronger (lambda (a b) ((make-flat-contract-stronger a) a b))
    #:generate (lambda (c) (make-flat-contract-generate c))
-   #:exercise (lambda (c) (make-flat-contract-exercise c))))
+   #:exercise (lambda (c) (make-flat-contract-exercise c))
+   #:list-contract? (λ (c) (make-flat-contract-list-contract? c))))
 
 (define ((build-contract mk default-name)
          #:name [name #f]
@@ -369,7 +389,8 @@
          #:val-first-projection [val-first-projection #f]
          #:stronger [stronger #f]
          #:generate [generate (λ (ctc) (λ (fuel) #f))]
-         #:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))])
+         #:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))]
+         #:list-contract? [list-contract? (λ (ctc) #f)])
 
   (let* ([name (or name default-name)]
          [first-order (or first-order any?)]
@@ -379,7 +400,11 @@
                                         (val-first-first-order-projection name first-order)))]
          [stronger (or stronger as-strong?)])
 
-    (mk name first-order projection val-first-projection stronger generate exercise)))
+    (mk name first-order 
+        projection val-first-projection
+        stronger 
+        generate exercise
+        list-contract?)))
 
 (define ((get-val-first-first-order-projection get-name get-first-order) c)
   (val-first-first-order-projection (get-name c) (get-first-order c)))
@@ -403,12 +428,19 @@
    (contract-struct-projection b)))
 
 (define make-contract
-  (build-contract make-make-contract 'anonymous-contract))
+  (procedure-rename 
+   (build-contract make-make-contract 'anonymous-contract)
+   'make-contract))
 
 (define make-chaperone-contract
-  (build-contract make-make-chaperone-contract 'anonymous-chaperone-contract))
+  (procedure-rename
+   (build-contract make-make-chaperone-contract 'anonymous-chaperone-contract)
+   'make-chaperone-contract))
 
-(define make-flat-contract (build-contract make-make-flat-contract 'anonymous-flat-contract))
+(define make-flat-contract
+  (procedure-rename
+   (build-contract make-make-flat-contract 'anonymous-flat-contract)
+   'make-flat-contract))
 
 ;; property should be bound to a function that accepts the contract and
 ;; returns a list of contracts that were the original arguments to the or/c