YES-OR-NO? on steroids.

  ; ,open fluids srfi-23 formats receiving
  ; (define with-fluid let-fluid)

  ;; (INQUIRE-USER <question> <answer-alist> [<default-answer> ;procedure
  ;;               [<eof-thunk>]])
  ;;   Each element of ANSWER-ALIST, a proper list, should be a pair with
  ;;   the form
  ;;     (<answer-specification> <continuation>)
  ;;   Ask QUESTION and dispatch the user's answer by searching for a key
  ;;   in ANSWER-ALIST.  No further description is given -- see below --.
  ;;
  ;;   ANSWER-SPECIFICATIONS have the following meanings:
  ;;
  ;;     - a procedure of one argument
  ;;         -- apply this predicate to the line of user input to test if
  ;;            it should match.
  ;;     - a string
  ;;         -- compare the string, case-insensitively, to the user input
  ;;     - the symbol YES
  ;;         -- as if the specification were a list of certain predefined
  ;;            affirmative answers
  ;;     - the symbol NO
  ;;         -- as if the specification were a list of certain predefined
  ;;            negative answers
  ;;     - a proper list of answer specifications
  ;;         -- test to see if any of the elements match
  ;;     - #T
  ;;         -- automatically matches
  ;;
  ;; The exact action that INQUIRE-USER performs to ask a question of the
  ;; user depends on two fluid variables.  These are fluids in order that
  ;; a programmer may replace them if the user is not interacting through
  ;; a console (e.g., for a GUI program), or the programmer may desire to
  ;; use a different format for the question, or something.
  ;;
  ;; ($USER-INQUIRER <inquirer-procedure>)                ;fluid variable
  ;;   INQUIRER-PROCEDURE must match the signature of INQUIRE-USER.  This
  ;;   procedure will be called by INQUIRE-USER.
  ;;
  ;; The top-level value of $USER-INQUIRER can be described as, using the
  ;; same signature as INQUIRE-USER:
  ;;
  ;;   Ask QUESTION and dispatch the user's answer by searching for a key
  ;;   in ANSWER-ALIST.  Should the user's answer be an EOF, keep trying,
  ;;   but stop after a certain number of retries.  In the case where the
  ;;   user should input an answer with no matching answer specification,
  ;;   the question is reiterated.
  ;;
  ;;   A blank line indicates DEFAULT-ANSWER.
  ;;
  ;; ($MAX-USER-INQUIRIES <maximum>)                      ;fluid variable
  ;;   MAXIMUM specifies the number of iterations of inquiry that will be
  ;;   executed before giving up.  The top-level value in this is 10.
  ;;
  ;; $MAX-USER-INQUIRIES isn't actually necessarily used.  It is merely a
  ;; hint to the current inquirer procedure.
  ;;
  ;; The procedures WITH-USER-INQUIRER & WITH-MAX-USER-INQUIRIES create a
  ;; layer of abstraction over the two fluids.
  ;;
  ;; There is one utility for inquirers other than the default one:
  ;;
  ;; (USER-ANSWER-MATCHES? <user-answer> <answer-spec>)        ;procedure
  ;;   Does USER-ANSWER match ANSWER-SPEC as described above?
  ;;
  ;; A variant of Y-OR-N-P is trivially defined at the bottom:
  ;;
  ;; (YES-OR-NO? <question> <default> [<eof-thunk>])           ;procedure
  ;;   Ask QUESTION.  Return #T to indicate positive input from the user,
  ;;  or #F to indicate negative input.  

  ;;;; Implementation

  (define (user-answer-matches? answer answer-spec)
    (cond ((eq? answer-spec #t)
           #t)
          ((procedure? answer-spec)
           (answer-spec answer))
          ((string? answer-spec)
           (string-ci=? answer answer-spec))
          ((eq? answer-spec 'yes)
           (user-answer-matches? answer user-inquiry:*yes*))
          ((eq? answer-spec 'no)
           (user-answer-matches? answer user-inquiry:*no*))
          ((proper-list? answer-spec)
           (any (lambda (answer-spec*)
                  (user-answer-matches? answer answer-spec*))
                answer-spec))
          (else
           (error "Bad user answer spec"
                  answer-spec))))

  (define user-inquiry:default-inquirer
    (lambda (question answer-alist . opt-args)
      (define max-count (fluid $max-user-inquiries))
      (receive (default eof-thunk)
          (cond ((null? opt-args)
                 (values #f
                   (lambda ()
                     (error "EOF after maximum yes/no retries"
                            max-count))))
                ((null? (cdr opt-args))
                 (values (and (car opt-args)
                              ;; Cheap hack to figure out what the system
                              ;; prefers to format arbitrary objects.
                              (format #f "~A" (car opt-args)))
                   (lambda ()
                     (error "EOF after maximum yes/no retries"
                            max-count))))
                ((null? (cddr opt-args))
                 (values (car opt-args) (cadr opt-args)))
                (else
                 (apply error "Too many arguments"
                        user-inquiry:default-inquirer
                        question answer-alist
                        opt-args)))
        (define read-line/default
          (if default
              (lambda ()
                (let ((l (read-line)))
                  (cond ((eof-object? l)
                         l)
                        ((zero? (string-length l))
                         default)
                        (else
                         l))))
              read-line))
        (define (maybe-retry count)
          (newline)
          (cond ((zero? count)
                 (eof-thunk))
                (else
                 (display "I shall ask only another ")
                 (write count)
                 (display (if (= count 1) " time." " times."))
                 (newline)
                 (loop (- count 1)))))
        (define (loop count)
          (display question)
          (cond (default
                 (display " [")
                 (display default)
                 (display "]")))
          (display " ")
          (let ((line (read-line/default)))
            (cond ((eof-object? line)
                   (maybe-retry count))
                  ((assoc* line answer-alist user-answer-matches?)
                   => (lambda (probe) ((cadr probe) line)))
                  (else
                   (display
                    "  Please answer the question that was asked.")
                   (newline)
                   (loop count)))))

        (loop max-count))))

  (define user-inquiry:default-max 10)

  (define $user-inquirer (make-fluid user-inquiry:default-inquirer))
  (define $max-user-inquiries (make-fluid user-inquiry:default-max))

  (define (with-user-inquirer user-inquirer thunk)
    (with-fluid $user-inquirer user-inquirer thunk))
  (define (with-max-user-inquiries max thunk)
    (with-fluid $max-user-inquiries max thunk))

  (define user-inquiry:*yes*
    '("y" "yes" "yeah" "yeh" "yah" "aye" "ayup" "yup" "indeed" "affirmed"
      "affirmative" "positive" "sure" "ok" "okay"))
  (define user-inquiry:*no*
    '("n" "no" "nah" "na" "naw" "nope" "no way" "negative" "not affirmed"
      "not affirmative" "nyet!" "nay"))

  (define (inquire-user question answer-alist . opt-args)
    (apply (fluid $user-inquirer)
           question
           answer-alist
           opt-args))

  ;; YES-OR-NO? is trivially defined in terms of INQUIRE-USER.
  (define (yes-or-no? question . opt-args)
    (apply inquire-user question
           `((yes ,(lambda (line) #t))
             (no  ,(lambda (line) #f)))
           opt-args))